/Users/yngvelevinsen/Programming/dynac/dynac.F90

Go to the documentation of this file.

    block data
      implicit real *8(a-h, o-z)
      common /consta/vl, pi, xmat, rpel, qst
      common /gaus13/h(13), t(13)
      common /gaus17/h1(17), t1(17)
      common /radia/trt, rmoy, xintf, crae
      data crae, xintf/2.81793910e-13, .86967/
      data vl, xmat, rpel, qst/2.99792458e10, 938.27231, 28.17938e-14, 1./
      data h/.040484004, .092121499, .138873510, .178145981, .207816048, .226283180, .232551553, .226283180, .207816048, &
        .178145981, .138873510, .092121499, .040484004/
      data t/ -.984183055, -.917598399, -.801578091, -.642349339, -.448492751, -.230458316, 0., .230458316, .448492751, &
        .642349339, .801578091, .917598399, .984183055/
      data h1/ -.990575473, -.950675522, -.880239154, -.781514004, -.657671159, -.512690537, -.351231763, -.178484181, &
        0., .178484181, .351231763, .512690537, .657671159, .781514004, .880239154, .950675522, .990575473/
      data t1/.024148303, .055459529, .085036148, .111883847, .135136368, .154045761, .168004102, .176562705, &
        .179446470, .176562705, .168004102, .154045761, .135136368, .111883847, .085036148, .055459529, .024148303/
      common /randu/ck(15), kmax
      ! randu(j):contains the Chebitcheff coefficients Ck in table 20.
      ! kmax is the total number of these coefficients(from 1)
      data (ck(j), j=1, 7)/.98933556, -.68838689, .28191718, -.66389307e-01, .87406854e-02, -.59534602e-03, &
        .16300617e-04/
      ! xx        data (ck(j),j=1,10)/.99927015,-.78398394,.44577741,
      ! xx     *        -.18252873,.51928922e-01,-.99821428e-02,
      ! xx     *        .1259644e-02,-.99460265e-04,.44427251e-05,
      ! xx     *        -.85528336e-07/
      ! xx        data (ck(j),j=1,12)/.99989097,-.79469098,.48376369,
      ! xx     *        -.23183581,.85333907e-01,-.23354050e-01,
      ! xx     *        .46284273e-02,-.64840101e-03,.62211306e-04,
      ! xx     *        -.38752189e-05,.14087289e-06,-.22650639e-08/
      common /const/pi2, sqpi, pwtpi, sqpi2, sq2pi
      ! pi2=pi*pi, sqpi=(pi/2)**3/2 , pwtpi=(2*pi)**3/2 ,sqpi2=sqrt(pi/2.)
      data kmax/7/
    end block data
    ! *******************************************************************
    ! PROGRAM DYNAC
    ! THIS SOFTWARE WAS ORIGINALLY PRODUCED BY CERN/PS, CEN/SACLAY

    ! @version 6.0R15
    ! @date 30-Dec-2015

    ! @author P. LAPOSTOLLE  CONSULTANT (Paris, France)
    ! @author E. TANKE       ESS (Lund, Sweden)
    ! @author S. VALERO      CONSULTANT (Paris, France)

    ! Modified and maintained by :
    ! - TANKE Eugene
    ! - VALERO Saby
    ! *******************************************************************
    program dynac
      implicit real *8(a-h, o-z)
      parameter(ncards=64, iptsz=100002, maxcell=3000, maxcell1=3000)
      common /itvole/itvol, imamin
      common /consta/vl, pi, xmat, rpel, qst
      common /const/pi2, sqpi, pwtpi, sqpi2, sq2pi
      ! pi2=pi*pi, sqpi=(pi/2)**3/2 , pwtpi=(2*pi)**3/2 ,sqpi2=sqrt(pi/2.)
      common /fene/wdisp, wphas, wx, wy, rlim, ifw
      common /dyn/tref, vref
      common /dyni/vrefi, trefi, fhinit, acpt
      logical acpt
      common /ttfc/tk, t1k, t2k, sk, s1k, s2k, fh
      common /azlist/icont, iprin
      common /carac/cara(10)
      common /compt/nrres, nrtre, nrbunc, nrdbun
      common /compt1/ndtl, ncavmc, ncavnm
      common /sc3/beamc, scdist, sce10, cplm, ect, apl, ichaes, iscsp
      common /faisc/f(10, iptsz), imax, ngood
      common /tapes/in, ifile, meta
      common /shif/dtiph, shift
      common /tilt/tipha, tix, tiy, shifw, shifp
      common /bloc21/be, apb(2), layl, layx, rabt
      real *8 layl, layx
      common /poro/irot1, irot2
      logical irot1, irot2
      common /etchas/fractx, fracty, fractl
      common /davcom/dav1(maxcell1, 40), davtot, iitem(maxcell1), idav
      common /davprt/shortl
      common /shortl/davprt
      common /etcha1/dav2(maxcell1, 33), ichas(iptsz), chasit
      common /etcha3/ichxyz(iptsz)
      common /dcspa/iesp
      common /tstnt/intgct
      common /tabsch/ideg, nn, pchoix
      common /cmpte/iell
      common /cptemit/xltot(maxcell1), nbemit
      common /rfield/ifield
      common /posc/xpsc
      common /rander/ialin
      common /apel/iapel
      common /qskew/qtwist, iqrand, itwist, iaqu
      common /femt/iemgrw, iemqesg
      common /mode/eflvl, rflvl
      common /aerp/vphase, vfield, ierpf
      common /blvl/bflvl
      common /rec/irec
      common /histo/centre(6)
      common /grparm/glim(4, 2), glim1(4, 2), glim2(4, 2), patitl, ngraphs(100), idwdp, igrprm, ngrafs
      common /zones/frms(6), nzone
      logical chasit, shift, itvol, imamin
      logical ichaes, iesp, ifield, ialin, itwist, iemgrw
      character *80 cara, cmnt, text, patitl, ofeldf, ofelds
      character *80 davprt(maxcell1)
      character *8 kle(ncards), kley
      character *12 fdrft
      character *160 titre
      character iitime*30
      common /cespch/nchge, ichsp, nppi
      logical ichsp
      common /drfq/prfq(9)
      common /alin/xl, yl, xpl, ypl
      common /trcmp/pchoixa
      common /pltprf/sprfx(3000), sprfy(3000), sprfl(3000), sprfw(3000), sprfp(3000), sprng(3000), iprf
      common /mcs/imcs, ncstat, cstat(20)
      common /secdr/iseor
      logical iseor
      common /rayshy/iraysh
      common /trfq/icour, ncell
      common /newref/dephas, dewref, iref, irefw
      common /tofev/ttvols
      common /conti/irfqp
      logical irfqp
      common /rf1ptq/tvolt, avolt, fph, mlc, nceltot
      common /strip/atm, qs, atms, ths, qop, sqst(6), anp, nqst
      common /grot/rzot, izrot
      ! allow plotting the beam after sector nsprint ******
      common /isector/nsector, nsprint
      common /mingw/mg
      common /xposi/xpost(10), xlce(2), xpax(2), iscx(2)
      common /fcont/ifcont
      logical ifcont, mg, ffound
      ! ********************************************
      ! reservation for TRACE3D related stuff
      common /trace3d/trace3h(100), trace3t(maxcell1), tif, kt3h, kt3t, fid
      common /t3dfld/fldctr(15), zend(15), t3d
      logical t3d, xiset
      character *128 trace3h, trace3t, tif, tifa, tifb
      ! ********************************************
      common /elq/inisk
      integer inisk
      logical izrot
      logical iraysh, cfound
      data kle/'GEBEAM', 'INPUT', 'RDBEAM', 'ETAC', 'DRIFT', 'QUADRUPO', 'SEXTUPO', 'QUADSXT', 'SOLENO', 'SOQUAD', &
        'BMAGNET', 'CAVMC', 'CAVSC', 'FIELD', 'HARM', 'BUNCHER', 'RFQCL', 'NEWF', 'NREF', 'SCDYNAC', 'SCDYNEL', 'SCPOS', &
        'TILT', 'TILZ', 'CHANGREF', 'TOF', 'REJECT', 'ZROT', 'ALINER', 'ACCEPT', 'EMIT', 'EMITGR', 'COMMENT', 'WRBEAM', &
        'ENVEL', 'CHASE', 'RWFIELD', 'RANDALI', 'TWQA', 'EMIPRT', 'MMODE', 'RFQPTQ', 'STRIPPER', 'STEER', 'ZONES', &
        'PROFGR', 'SECORD', 'RASYN', 'FDRIFT', 'FSOLE', 'EGUN', 'COMPRES', 'STOP', 'REFCOG', 'FPART', 'QUAELEC', &
        'QUAFK', 'CAVNUM', 'EDFLEC', 'EMITL', 'RFKICK', 'FIRORD', 'DCBEAM', 'T3D'/
      integer narg, i
      character *80 inarg, myarg(10), myfile, wfile, infiln, shortl
      character *10 plane
      logical g77, gfortran
      ! if mg=.true., use MINGW on windows, which has a different result for
      ! ctime function than standard gfortran
      ! default is mg=.false. This can be set by giving mingw as argument on
      ! the command line
      mg = .false.
      ! get arguments from the command line
      ! format for dynac:
      ! dynac file1 [-h]
      ! where: -file1 is the input file, describing the beamline
      ! -h  print help info
      gfortran = .true.
      ! g77 in case of g77, set g77=.true. ; in case of gfortran,
      ! set g77=.false.
      g77 = .false.
      if (g77) gfortran = .false.
      narg = 0
      if (gfortran) then
        do
          call get_command_argument(narg, inarg)
          if (len_trim(inarg)==0) exit
          narg = narg + 1
          ! g77 in case of g77, comment out the next line; in case of
          ! gfortran, leave it in
          myarg(narg) = trim(inarg)
        end do
      else
        write (6, *) 'Compatible with g77'
      end if
      ! INPUT ARGUMENTS:
      ! *******************************************************************
      if (gfortran) then
        ffound = .false.
        do i = 2, narg
          text = myarg(i)
          if (text(1:1)/='-') then
            ! the input argument is the name of the input file
            write (6, 2917) myarg(i)
2917        format ('Input file: ', a)
            infiln = myarg(i)
            ! 7 or 'in' is the unit corresponding to the dynac input file
            ! describing the accelerator or transport line
            open (7, file=myarg(i), status='unknown')
            ffound = .true.
          else
#ifdef MINGW
            ! if mg=.true., use MINGW on windows, which has a different result
            ! for ctime function than standard gfortran
            mg = .true.
            write (6, *) 'Using MINGW gfortran format on MSWindows'
#endif
            if (myarg(i)=='-h') then
              ! print out of help message, starting with DYNAC version
              write (6, 3101)
              write (6, *) 'Command format:'
              write (6, *) 'dynacv6_0 [-h] [-mingw] [file1]'
              write (6, *) 'where file1 is the input file, describing ', 'the beamline'
              write (6, *) 'Optional arguments:'
              write (6, *) '-h will list the argument options (this ', 'list)'
              stop
            end if
          end if
        end do
        if (.not. ffound) then
          write (6, *) 'Error: Input file name required'
          write (6, *) 'Type'
          write (6, *) 'dynacv6_0 -h'
          write (6, *) 'for syntax'
          stop
        end if
      end if
      ! *******************************************************************
      ! OUTPUT FILES:

      ! 'dynac.long'  : print extensive computations information

      ! 'dynac.short' : print essentials of beam dynamics information

      ! 'dynac.print' : printout of the envelope and the emittance of the
      ! beam in the directions  x, y and z at each position
      ! of the optical and accelerating elements, as well as
      ! the number of good particles

      ! 'dynac.dmp'   : printout of cavity cell related data:
      ! cell number,synchronous phase (deg),relativistic
      ! beta (output), output energy (MeV),
      ! hor. emittance (mm.mrad, normalized),
      ! ver. emittance (mm.mrad, normalized),
      ! longitudinal emittance (ns.kev)

      ! 'beam_core.dst': print the coordinates of the particles kept by
      ! CHASE

      ! 'beam_remove.dst': print the coordinates of the particles
      ! removed by CHASE

      ! 'dynac_in_pr.dst': print of the coordinates of the particles at the
      ! input of the machine

      ! 'emit.plot'      : datafile used for the plots

      ! *************************************************************************************************
      open (16, file='dynac.long', status='unknown')
      open (12, file='dynac.short', status='unknown')
      open (71, file='dynac.print', status='unknown')
      open (50, file='dynac.dmp', status='unknown')
      open (61, file='beam_core.dst', status='unknown')
      open (60, file='beam_remove.dst', status='unknown')
      open (11, file='dynac_in_pr.dst', status='unknown')
      open (66, file='emit.plot', status='unknown')
      ! ****************************************************************************************************
      ! *******files deactivated in the code

      ! 'emlg.data': print at each position of space charge computation:
      ! the length(m), the longitudinal emittance growth (ns.keV),
      ! the kinetic energy (MeV), the number of good particles

      ! 'emtr.data': print at each position of space charge computation:
      ! the length(m), the hor. and ver. normalized emittances (mm.mrad)

      ! 'chemlg.data': as 'emlg.data' but with CHASE

      ! 'chemtr.data': as 'emtr.data' but with CHASE

      ! 'ntxyz.data' : print at each position of space charge computation:
      ! the coordinates of the particles in the 3D plane (x(cm), y(cm) and z(cm))
      ! This file is rewound each time, only the last result is kept

      ! 'rms.size' :print at each position of space charge computation the RMS(m) of the bunch
      ! in x, y and z-direction

      ! 'egun_prtcl.data'   : print of the coordinates of the particle icont (see RDBEAM) along the DC EGUN

      ! 'champ_sol.data'    : plot  field in the solenoid
      ! ****************************************************************************************
      ! SV 24/08/2015
      open (13, file='emlg.data', status='unknown')
      ! old       open(14,file='emtr.data',status='unknown')
      ! omment       open(15,file='chemlg.data',status='unknown')
      ! omment       open(17,file='rms.size',status='unknown')
      ! omment       open(18,file='chemtr.data',status='unknown')
      ! omment       open(19,file='nxyz.data',status='unknown')
      ! omment       open(21,file='ntxyz.data',status='unknown')
      ! omment       open(49,file='egun_prtcl.data',status='unknown')
      ! ****************************************************
      ! omment       write(14,7787)
      ! omment       write(18,7787)
      ! omment7787   format(4x,'N',6x,'length',5x,'emitx',5x,'emity')
      ! omment       write(13,7788)
      ! omment       write(15,7788)
      ! omment7788   format(4x,'N',6x,'length',5x,'emitz',6x,'energy',1x,'part.good')
      ! ********************************************************
      ! SV 24/10/2015
      ! c       write(13,99)
      ! c99     format(3x,'ncav',2x,'ncell',2x,'pos I(cm)',4x,'pos S(cm)',6x,
      ! c     *'L cell(cm)',5x,'W(Mev)',7x,'dw(Mev)',6x,'TOF(dg)',7x,'Ph RF(dg)'
      ! c     *,6x,'pos M(cm)',5x,'WM(Mev)',7x,'dwM(Mev)',6x,
      ! c     *'TOFM(dg)',5x,'PhM RF(dg)')
      ! **************************************************************************************
      ! initialize constants
      ! in corresponds to dynac input file
      in = 7
      ! itout corresponds to TRACE3D input file
      itout = 48

      ! pi2=pi*pi, sqpi=(pi/2)**3/2 , pwtpi=(2*pi)**3/2 ,sqpi2=sqrt(pi/2.)
      pi = 4.*atan(1.)
      pi2 = pi*pi
      sqpi = (pi/2)**3/2
      pwtpi = (2*pi)**3/2
      sqpi2 = sqrt(pi/2.)
      ! initialize the number of charge states to 1
      ncstat = 1
      ! initialize the # of zones (see ZONES card) to zero
      izrot = .false.
      ofeldf = ' '
      ofelds = ' '
      icour = 0
      ! initialize trace3d related stuff
      ! frequency indicator
      fid = 1.
      t3d = .false.
      xiset = .false.
      kt3h = 1
      trace3h(kt3h) = ' $DATA'
      kt3t = 0
      ! DONE:
      ! DATA KLE/'GEBEAM','INPUT','RDBEAM','ETAC','DRIFT',
      ! 1*       'QUADRUPO',        ,         ,'SOLENO',         ,
      ! 2*        'BMAGNET',        ,'CAVSC'  ,'FIELD' ,         ,
      ! 3*        'BUNCHER',        ,'NEWF'   ,        ,'SCDYNAC',
      ! 11*                 ,'CAVNUM',         ,        ,
      ! TO LOOK AT:
      ! DATA KLE/                ,        ,
      ! 1*                 ,'SEXTUPO','QUADSXT',        ,'SOQUAD',
      ! 2*                 ,         ,         ,        , 'HARM' ,
      ! 3*                 ,'RFQCL',           ,'NREF',        ,
      ! 4*        'SCDYNEL','SCPOS','TILT','TILZ','CHANGREF',
      ! 5*        'TOF','REJECT','ZROT','ALINER',
      ! 7*        'RWFIELD','RANDALI','TWQA','EMIPRT',
      ! 8*        'MMODE','RFQPTQ',        ,'STEER',
      ! 9*                ,        ,       ,'FDRIFT','FSOLE',
      ! 10*                         'REFCOG','FPART',       ,
      ! 11*        'QUAFK',         ,       ,       ,'RFKICK'

      ! IGNORE: 'ZONES','STOP','T3D','DCBEAM','FIRORD','COMMENT'
      ! 'EMIT','EMITGR','WRBEAM','ENVEL','REJECT','CHASE'
      ! 'ACCEPT','EMITL','EGUN','COMPRES','RASYN','SECORD'
      ! 'STRIPPER','EDFLEC','PROFGR','QUAELEC','CAVMC'
      acpt = .false.
      irfqp = .false.
      inisk = 0
      ttvols = 0.
      iprf = 1
      ncell = 0
      nzone = 0
      eflvl = 0.
      rflvl = 0.
      bflvl = 0.
      nbemit = 0
      iell = 0
      imcs = 0
      ifw = 1
      wdisp = 1000.
      wphas = 400.*pi
      wx = 100.
      wy = 100.
      rlim = 140.
      nrtre = 0
      do i = 1, 6
        centre(i) = 0.
      end do
      do i = 1, maxcell1
        davprt(i) = ''
      end do
      do i = 1, iptsz
        ichas(i) = 1
        ichxyz(i) = 1
      end do
      shift = .false.
      ichaes = .false.
      iseor = .false.
      iraysh = .false.
      icont = iptsz + 5
      iprin = 1
      nrres = 0
      ndtl = 0
      ncavnm = 0
      ncavmc = 0
      nrbunc = 0
      dtiph = 0.
      icont = 150000
      intgct = 0
      itye = 1000
      ierpf = 0
      ialin = .false.
      itwist = .false.
      ichsp = .false.
      iesp = .false.
      itvol = .false.
      imamin = .false.
      chasit = .false.
      ifield = .false.
      iemgrw = .false.
      idav = 0
      davtot = 0.
      iapel = 1
      iaqu = 1
      xpsc = .5
      fractx = 1.
      fracty = 1.
      fractl = 1.
      iscsp = 0
      ifile = 11
      imax = 0
      ! default for beams is to be bunched (not continuous)
      ifcont = .false.
      ! *******************************************************
      write (6, 3101)
      write (16, 3101)
      write (12, 3101)
3101  format ('****** DYNAC V6.0R15 (Beta test), 30-Dec-2015 *******')
      if (gfortran) then
        write (16, *) 'Input file: ', infiln
        write (12, *) 'Input file: ', infiln
      end if
      text = ' '
      call mytime(iitime)
      if (mg) then
        ! using MINGW style gfortran format: 03/30/10 20:51:06 (10 is 2010)
        text(1:4) = '    '
        if (iitime(1:2)=='01') text(5:7) = 'Jan'
        if (iitime(1:2)=='02') text(5:7) = 'Feb'
        if (iitime(1:2)=='03') text(5:7) = 'Mar'
        if (iitime(1:2)=='04') text(5:7) = 'Apr'
        if (iitime(1:2)=='05') text(5:7) = 'May'
        if (iitime(1:2)=='06') text(5:7) = 'Jun'
        if (iitime(1:2)=='07') text(5:7) = 'Jul'
        if (iitime(1:2)=='08') text(5:7) = 'Aug'
        if (iitime(1:2)=='09') text(5:7) = 'Sep'
        if (iitime(1:2)=='10') text(5:7) = 'Oct'
        if (iitime(1:2)=='11') text(5:7) = 'Nov'
        if (iitime(1:2)=='12') text(5:7) = 'Dec'
        text(8:8) = ' '
        text(9:10) = iitime(4:5)
        text(11:13) = ' 20'
        text(14:15) = iitime(7:8)
        text(16:19) = ' at '
        text(20:27) = iitime(10:17)
      else
        ! standard gfortran format: Tue Mar 30 20:51:06 2010
        text(1:11) = iitime(1:11)
        text(12:15) = iitime(21:24)
        text(16:19) = ' at '
        text(20:27) = iitime(12:19)
      end if
      write (6, 789) text(1:27)
789   format ('Started on ', a27)
      write (16, *) 'Started on ', text(1:27)
      write (12, *) 'Started on ', text(1:27)
      call cpu_time(exstrt)
      ! Read title
      read (in, 3333) titre(1:80)
      write (16, 3334) titre(1:80)
      write (12, 3334) titre(1:80)
3333  format (a80)
3334  format (1x, a80)
      ! Read the input file and check for valid cards
      do
        cfound = .false.
        read (in, 3333) cmnt(1:80)
        if (cmnt(1:1)==';') then
          write (16, 3334) cmnt(1:80)
          cycle
        else
          kley = cmnt(1:8)
        end if
        do i = 1, ncards
          if (kley==kle(i)) then
            cfound = .true.
            exit
          end if
        end do
        if (cfound) then
          ! *********************************************************************
          ! GEBEAM    1  | INPUT    2  | RDBEAM   3  | ETAC    4  | DRIFT    5
          ! QUADRUPO  6  | SEXTUPO  7  | QUADSXT  8  | SOLENO  9  | SOQUAD   10
          ! BMAGNET   11 | CAVMC    12 | CAVSC    13 | FIELD   14 | HARM     15
          ! BUNCHER   16 | RFQCL    17 | NEWF     18 | NREF    19 | SCDYNAC  20
          ! SCDYNEL   21 | SCPOS    22 | TILT     23 | TILZ    24 | CHANGREF 25
          ! TOF       26 | REJECT   27 | ZROT     28 | ALINER  29 | ACCEPT   30
          ! EMIT      31 | EMITGR   32 | COMMENT  33 | WRBEAM  34 | ENVEL    35
          ! CHASE     36 | RWFIELD  37 | RANDALI  38 | TWQA    39 | EMIPRT   40
          ! MMODE     41 | RFQPTQ   42 | STRIPPER 43 | STEER   44 | ZONES    45
          ! PROFGR    46 | SECORD   47 | RASYN    48 | FDRIFT  49 | FSOLE    50
          ! EGUN      51 | COMPRES  52 | STOP     53 | REFCOG  54 | FPART    55
          ! QUAELEC   56 | QUAFK    57 | CAVNUM   58 | EDFLEC  59 | EMITL    60
          ! RFKICK    61 | FIRORD   62 | DCBEAM   63 | T3D     64 |
          ! *********************************************************************
          if (i==1) then
            ! AFTER GEBEAM:Generates randomly the input beam
            write (16, *) ' TYPE CODE:GEBEAM********* '
            call monte
            write (16, *) '********************************'
          else if (i==2) then
            ! AFTER INPUT: define the dynamics at input
            ! --- INPUT must be preceded by GEBEAM
            ! --- the reference (synchronous) particle is the c.o.g of the bunch
            ! --- ENTRY:
            ! ---- 1) uem, atm, qst
            ! ---    uem : unit of Rest mass in MeV
            ! Examples:
            ! proton:938.27231  MeV
            ! H-    :939.3145   MeV
            ! mesons:33.9093    MeV
            ! pions :139.5685   MeV
            ! kaons :493.667    MeV
            ! electrons : 0.511 MeV
            ! --- atm : Atomic number
            ! --- qst : charge (unit of charge) of the reference

            ! ----  2) enedep,tof
            ! ---      enedep: Kinetic energy of the reference
            ! ---      tofini: Time of flight of the reference at input (sec)
            write (16, *) ' TYPE CODE:INPUT ********'
            call entre
            write (16, *) '********************************'
          else if (i==3) then
            ! AFTER RDBEAM: Read the input beam in the disk
            write (16, *) 'TYPE CODE:RDBEAM **********'
            ! --- ENTRY
            ! ---- 1) filen : filename of file containing the particle distribution
            ! ---- 2) iflag : flag type of distribution file
            ! ---     iflag = 0 particle coordinates x,xp,y,yp,z,zp with z in rad
            ! ---     iflag = 1 particle coordinates x,xp,y,yp,z,zp,q,m0 with z in rad
            ! ---     iflag = 2 particle coordinates x,xp,y,yp,z,zp,q with z in rad
            ! ---     iflag = 10 particle coordinates x,xp,y,yp,z,zp with z in ns
            ! ---     iflag = 11 particle coordinates x,xp,y,yp,z,zp,q,m0 with z in ns
            ! ---     iflag = 12 particle coordinates x,xp,y,yp,z,zp,q with z in ns
            ! ---     add 100 to the above iflg values to read a file that has Wref as
            ! ---     4th parameter on line 1
            ! ---- 3) freq, tof
            ! ---     freq: RF frquency (MHz)
            ! ---     tof: phase offset to be applied  to the beam (deg)

            ! ---- 4) uem, atm, qst
            ! like ENTRY in type code INPUT

            read (in, 3333) myfile(1:80)
            write (16, *) 'Distribution file: ', myfile(1:80)
            open (55, file=myfile, status='unknown')
            call adjrfq
            write (16, *) '********************************'
          else if (i==4) then
            ! AFTER ETAC :possibility of a multiple charge state beam
            write (16, *) 'TYPE CODE:ETAC **********'
            kt3h = kt3h + 1
            trace3h(kt3h) = 'ERROR: ETAC not supported'
            call etac
            write (16, *) '********************************'
            ! AFTER DRIFT : dl:drift length (cm),if dl is negatif no space charge effect
          else if (i==5) then
            write (16, *) 'TYPE CODE:DRIFT **********'
            read (in, *) dl
            kt3t = kt3t + 1
            write (tif, 6001) kt3t, kt3t, 10.*dl
6001        format ('  nt(', i4, ')= 1, a(1,', i4, ')=', f12.6)
            trace3t(kt3t) = tif
            call drift(dl)
            write (16, *) '********************************'
          else if (i==6) then
            ! AFTER QUADRUPO: quadrupole
            ! BQUAD: field at pole tip (kG)
            ! XLQUA: EFFECTIVE LENGHT (cm )
            ! RG:    APERTURE RADIUS (cm)
            write (16, *) 'TYPE CODE:QUADRUPO**********'
            read (in, *) xlqua, bquad, rg
            kt3t = kt3t + 1
            write (tif, 6002) kt3t, kt3t, 10.*bquad/rg, xlqua*10.
6002        format ('  nt(', i4, ')= 3, a(1,', i4, ')= ', f9.5, ' , ', f9.5)
            trace3t(kt3t) = tif
            call qalva(bquad, xlqua, rg)
            write (16, *) '********************************'
          else if (i==7) then
            ! AFTER SEXTUPO: sextupole
            ! IMK2: IFLAG (see arg)
            ! ARG = KS2 (cm-3) if IMK2 = 0, otherwise ARG = BSEX (kG)
            ! XLSEX : EFFECTIVE LENGHT (CM )
            ! RG :APERTURE RADIUS (CM)
            write (16, *) 'TYPE CODE:SEXTUPO**********'
            read (in, *) imk2, arg, xlsex, rg
            call sextu(imk2, arg, xlsex, rg)
            write (16, *) '********************************'
          else if (i==8) then
            ! AFTER QUADSXT:
            ! quadrupole associated with sextupole
            ! IKSQ: IFLAG (see ARGS and ARGQ)
            ! ARGS: strength of SEXTUPOLE
            ! IKSQ = 0, then ARGS = KS2 (cm-3), otherwise ARGS = FIELD BS(kG)
            ! ARGQ: strength of QUADRUPOLE
            ! If IKSQ = 0, then ARGQ = K2 (cm-2), otherwise ARGQ = FIELD BQ(kG)
            ! XLQUA : EFFECTIVE LENGHT OF THE LENS(cm)
            ! RG : APERTURE RADIUS OF THE LENS (cm)
            write (16, *) 'TYPE CODE:QUADSXT**********'
            read (in, *) iksq, args, argq, xlqua, rg
            call qasex(iksq, args, argq, xlqua, rg)
            write (16, *) '********************************'
          else if (i==9) then
            ! AFTER SOLENO: solenoid
            ! IMKS: IFLAG (see ARG)
            ! ARG: IMKS = 0 then ARG is the strength K (cm-1), otherwise ARG is the field B (kG)
            ! XLSOL : EFFECTIVE LENGHT (CM )
            write (16, *) 'TYPE CODE SOLENO**********'
            read (in, *) imks, xlsol, arg
            call solnoid(imks, arg, xlsol)
            write (16, *) '********************************'
          else if (i==10) then
            ! AFTER SOQUAD: solenoid associated with quadrupole
            ! --IKSQ: IFLAG
            ! --ARGS: STRENGTH or FIELD OF SOLENOID
            ! If IKSQ = 0 then ARGS = K (cm-1), otherwise ARGS = B(kG)
            ! --ARGQ: STRENGTH or FIELD of QUADRUPOLE
            ! If IKSQ = 0 then ARGQ = K2 (cm-2), otherwise ARGQ = B(kG)
            ! SIGN CONVENTIONS:
            ! SOLENOID: K positive => rotate the transverse coordinates about the
            ! z-axis in the clockwise direction.
            ! QUADRUPOLE: K2 positive => focusing in the H plane (x,z)
            ! --XLSOL : EFFECTIVE LENGHT OF THE LENS(cm)
            ! --RG : APERTURE RADIUS OF THE LENS (cm)
            write (16, *) 'TYPE CODE:SOQUAD**********'
            read (in, *) iksq, args, argq, xlsol, rg
            call solquad(iksq, args, argq, xlsol, rg)
            write (16, *) '********************************'
          else if (i==11) then
            ! AFTER BMAGNET (sign conventions as in the code TRANSPORT)
            ! NSECTOR: number of sectors dividing the bending magnet
            ! WEDGE BENDING MAGNET
            ! ANGL : DEG  bend angle of the central trajectory
            ! RMO  : CM   radius of curvature of the central trajectory
            ! BAIM : KG   field of the bending magnet
            ! BAIM = 0  the field is computed from the momentum of the reference
            ! otherwise the momentum is computed from the field
            ! XN   :      FIELD GRADIENT (dimensionless,TRANSPORT: n)
            ! XB   :      NORMALIZED SECOND DERIVATIVE OF B (TRANSPORT : beta)
            ! AP(1) = AP(2) CM vertical half aperture (only if IPOLE = 0)
            ! ENTRANCE FACE
            ! PENT1 EK1 EK2 RAB1
            ! PENT1: DEG   angle of pole face rotation  (deg)
            ! RAB1 : CM    radius of curvature
            ! EK1  :       integral related to the extent of the fringing field (TRANSPORT K1)
            ! EK2  :       integral related to the extent of the fringing field (TRANSPORT K2)
            ! AP(1) : CM   vertical half aperture
            ! EXIT FACE
            ! PENT2 SK1 SK2  RAB2
            ! PENT2: DEG   angle of pole face rotation
            ! RAB2 : CM  radius of curvature
            ! SK1  :     integral related to the extent of the fringing field
            ! SK2  :     integral related to the extent of the fringing field
            ! AP(2) : CM   vertical half aperture

            ! SPACE CHARGE COMPUTATION is automatically provided in the routine
            ! CAUTION: with several states charges in the beam, ONLY THE SCHEFF METHOD MUST BE USED in the bending
            ! magnet
            ! ----------------------------------------------------------------------------------------------------------
            !----
            ! nsprint: allow plotting the beam after the sector number nsprint in file 13 ('emlg.data')
            ! cc        read(in,*) nsector,nsprint
            read (in, *) nsector
            read (in, *) angl, rmo, baim, xn, xb
            read (in, *) pent1, rab1, ek1, ek2, apb(1)
            ! if apb(1) ne 0 and if ek1 = 0 the program inserts a default value of ek1 = 0.5
            if (apb(1)/=0. .and. ek1<0.) ek1 = 0.5
            read (in, *) pent2, rab2, sk1, sk2, apb(2)
            ! if apb(2) ne 0 and  sk1 = 0 the program inserts a default value of sk1 = 0.5
            if (apb(2)/=0. .and. sk1<0.) sk1 = 0.5
            ! trace3d
            ! edge
            kt3t = kt3t + 1
            write (tif, 6005) kt3t, kt3t, pent1, 10.*abs(rmo), 20.*apb(1), ek1, ek2
6005        format ('  nt(', i4, ')= 9, a(1,', i4, ')=', f9.5, ' , ', f9.2, ' , ', f9.2, ' , ', f9.2, ' , ', f9.2)
            trace3t(kt3t) = tif
            ! bend
            kt3t = kt3t + 1
            write (tif, 6006) kt3t, kt3t, angl, 10.*abs(rmo)
6006        format ('  nt(', i4, ')= 8, a(1,', i4, ')=', f9.5, ' , ', f9.2, ' , 0 , 0 ')
            trace3t(kt3t) = tif
            ! edge
            kt3t = kt3t + 1
            write (tif, 6005) kt3t, kt3t, pent2, 10.*abs(rmo), 20.*apb(2), sk1, sk2
            trace3t(kt3t) = tif


            call aimalv(angl, rmo, baim, xn, xb, ek1, ek2, pent1, rab1, sk1, sk2, pent2, rab2)
            write (16, *) '********************************'
          else if (i==12) then
            ! AFTER CAVMC: Multicell accelerating element
            ! the electromagnetic field can be read:
            ! in the file 'field.txt' in the form (z,E(z))
            ! or from the type code: HARM in the form of a Fourier series expansion
            write (16, *) 'TYPE CODE:CAVMC  **********'
            call restay
            write (16, *) '********************************'
          else if (i==13) then
            ! AFTER CAVSC: single cell accelerating element
            ! The transit time factors describe the eletromagnetic field
            write (16, *) 'TYPE CODE:CAVSC  **********'
            call etgap
            write (16, *) '********************************'
          else if (i==14) then
            ! AFTER FIELD
            ! --- the axial field of the cavity is read from file in the form (z,E(z)) with a step size h in z
            ! in the SUPERFISH format: z(m)  E(z) (V/m)
            ! PART: the step size h may be divided in 'part' elements (with PART (= >) 1)
            ! ATT:  the field E(z) is multiplied by ATT and converted in MV/cm

            write (16, *) 'TYPE CODE: FIELD  **********'
            write (16, *) 'ELECTRIC FIELD (z, E(z) ) '
            ! get filename of input file of the electromagnetic field in the form (z,E(z))
            read (in, 3333) myfile(1:80)
            ! write(16,*) 'Electromagnetic field file: ',myfile(1:80)
            ! check if file is already open
            iostats = int(ftell(20))
            if (iostats==-1) then
              ! file not yet open
              open (20, file=myfile, status='unknown')
              write (16, *) 'Opening field file: ', myfile(1:80)
              ofeldf = myfile
            else
              if (ofeldf/=myfile) then
                write (16, *) 'Closing field file: ', ofeldf
                write (16, *) 'Opening field file: ', myfile(1:80)
                close (20)
                open (20, file=myfile, status='unknown')
                ofeldf = myfile
              end if
            end if
            read (in, *) att
            ! omment       write(16,*) ' partition of a step h: ',part,' field factor: ', att
            ! conversion V/m (SUPERFISH) --> MV/cm
            att = 1.e-08*att
            write (16, *) ' * Read the cavity field from ', myfile(1:80)
            call fieldcav(att)
            write (16, *) '********************************'
          else if (i==15) then
            ! AFTER HARM: the field is read on the form of a Fourier series expansion
            write (16, *) ' TYPE CODE: HARM  **********'
            write (16, *) 'ELECTRIC FIELD (Fourier series expansion)'
            call rharm
            write (16, *) '********************************'
          else if (i==16) then
            ! After BUNCHER: buncher as a single element
            ! PV: Voltage
            ! PDP: PHASE OF RF (deg)
            ! PRLIM: aperture radius (cm)
            ! PHARM: harmonic factor (bucher fq.)/(DTL freq.)
            write (16, *) 'TYPE CODE:BUNCHER ************************'
            read (in, *) pv, pdp, pharm, prlim
            write (16, 7777) pv, pdp, prlim
7777        format (' BUNCHER CAVITY ', /, ' Voltage ', e12.5, ' MV', /, ' RF Phase ', e12.5, ' deg', &
              ' Aperture Radius ', e12.5, ' cm')
            kt3t = kt3t + 1
            write (tif, 6007) kt3t, kt3t, pv, pdp, pharm
6007        format ('  nt(', i4, ')=10, a(1,', i4, ')=', f9.5, ' , ', f9.2, ' , 1 , 1 , ', f5.1)
            trace3t(kt3t) = tif
            pdp = pdp*pi/180.
            call bunparm(pv, pdp, pharm, prlim)
            write (16, *) '********************************'
          else if (i==17) then
            ! AFTER RFQCL (single cell of a RFQ)
            write (16, *) 'TYPE CODE:RFQCL ************************'
            ! --- The parameter definitions of the cell are identical to the ones of TRACE3-D
            ! VR02: Maximum intervane potentiel difference divided by square of average vanne displacement kV/(mm2)
            ! AV  : product of accelerating efficience and maximum intervane voltage (kV)
            ! XLRFQ: cell length (mm)
            ! XPHRFQ: phase of RF (deg)
            ! TYPE: TYPE is one of the following
            ! 0 = standard cell, no acceleration
            ! 1 = standard cell, acceleration
            ! 2 = fringing field, no acceleration
            ! 3 = fringing field, acceleration

            read (in, *) vr02, av, xlrfq, xphrfq, type
            ! -----     convert in MV , m  in the array prfq(9)
            ! ---- prfq(1) : VR02 ( MV/(m*m) )
            ! ---- prfq(2) : AV (MV)
            ! ---- prfq(3) : cell length (m)
            ! ---- prfq(4) : phase of RF (deg)
            ! ---- prfq(5) : TYPE
            prfq(1) = vr02*1.e03
            prfq(2) = av*1.e-03
            prfq(3) = xlrfq*1.e-03
            prfq(4) = xphrfq
            prfq(5) = type
            ! --- The space charge routine SCHEFF only is available
            if (ichaes) then
              if (iscsp<3) then
                write (6, *) '*** HERSC and SCHERM cannot be used in', 'the RFQ'
                write (16, *) '*** HERSC and SCHERM cannot be used in', 'the RFQ'
                stop
              end if
              write (16, *) '***** beam current: ', beamc, ' mA'
            end if
            call rfq_o3
            write (16, *) '********************************'
          else if (i==18) then
            ! AFTER NEWF:define a new frequency (Hertz)
            if (imax==0) then
              write (16, *) ' INIT TOF HAS TO BE PRECEEDED BY GBEAM', ' OR RDBEAM'
              stop
            end if
            write (16, *) 'TYPE CODE:NEWF ************************'
            read (in, *) fh1
            ! record frequency change in view of trace3d file
            fh1 = 2.*pi*fh1
            fid = fh1/fh
            ! adjust beam current
            beamc = beamc*fh1/fh
            rflvl = rflvl*fh1/fh
            fh = fh1
            write (16, *) ' NEW FREQUENCY : ', fh/(2.*pi), ' Hertz'
          else if (i==19) then
            ! AFTER NREF: define a new syncronous particle
            ! ---- DEPHAS: the change of phase (DEG)
            ! ---- DEW   : the change of kinetic energy (see IREFW)
            ! ---- follow two falgs, IREF and IREFW
            ! ----  IF IREF=0: RELATIVE TO the previous synchronous particle
            ! ----  IF IREF=1: RELATIVE TO the previous COG
            ! ----  IF IREFW=0: DEWREF is in dW/W
            ! ----  IF IREFW=1: DEWREF is in dW (MeV)
            write (16, *) ' TYPE CODE:NREF  ***********'
            read (in, *) dephas, dewref, iref, irefw
            call refer
            write (16, *) '********************************'
          else if (i==20) then
            ! AFTER SCDYNAC
            ! ISCSP: METHOD FOR SPACE CHARGE COMPUTATIONS
            ! ISCSP=1  HERSC METHOD
            ! ISCSP=2  SCHERM METHOD
            ! ISCSP=3  SCHEFF METHOD
            write (16, *) ' TYPE CODE:SCDYNAC  ***********'
            read (in, *) iscsp
            ! sce10 =1 : call in quads,solenoids,accelarating elements
            ! sce10 =2 : call in drifts,accelarating elements
            ! sce10 =3 : call in quads,solenoids,drifts,accelarating elements
            ! BEAM CURRENT IN ma
            read (in, *) beamc, sce10
            if (.not. xiset) then
              kt3h = kt3h + 1
              write (tif, 7001) beamc
7001          format (' XI= ', f9.4)
              trace3h(kt3h) = tif
              xiset = .true.
            end if
            if (iscsp<=1) write (16, *) 'HERSC method  '
            if (iscsp==2) write (16, *) 'SCHERM method  '
            if (iscsp==3) write (16, *) 'SCHEFF method  '
            if (iscsp>3) then
              write (16, *) 'Error in SCDYNAC iscsp: ', iscsp
              stop
            end if
            write (16, *) ' Beam current : ', beamc, ' mA'
            ect = 4.
            ichaes = .true.
            if (iscsp<=1) then
              ! initialise the routine HERSC
              if (iscsp==1) ini = 0
              if (iscsp<1) ini = -1
              call hersc(ini)
              iscsp = 1
            end if
            ! ---  SCHERM, read third line as dummy
            if (iscsp==2) read (in, *) idum
            ! --- SCHEFF
            ! initialise the mesh of routine SCHEFF
            if (iscsp==3) then
              call schfdyn
            end if
            if (beamc==0.) ichaes = .false.
            write (16, *) '****************************'
          else if (i==21) then
            ! AFTER SCDYNEL: space charge computations in the current position (i.e.bending magnet)
            ! XTRANS is the acting lenght of the beam self-fields (cm)
            write (16, *) ' TYPE CODE:SCDYNEL ****'
            read (in, *) xtrans
            call cesp(xtrans)
            write (16, *) '****************************'
          else if (i==22) then
            ! AFTER SCPOS : change the position of space charge computation in gaps or cavities
            write (16, *) ' TYPE CODE:SCPOS(space charge position)****'
            read (in, *) xpsc
            if (xpsc>=1.) xpsc = .5
            write (16, *) '****************************'
          else if (i==23) then
            ! AFTER TILT:rotation and shift of beam ellipsoid
            ! ICG    : = 1 => REFERENCE PARTICLE IS THE C.O.G. OF THE BEAM
            ! ICG    : = 0 => IT IS DISTINCT FROM THE C.O.G.
            write (16, *) ' TYPE CODE:TILT *********************'
            read (in, *) icg
            read (in, *) tipha, tix, tiy, shifw, shifp
            call tiltbm(icg)
            write (16, *) '****************************'
          else if (i==24) then
            ! AFTER TILZ: tilt in the plane (x,z) around the c.o.g. of the upright ellipse
            write (16, *) ' TYPE CODE:TILZ *********************'
            read (in, *) tilta
            call tiltz(tilta)
            write (16, *) '****************************'
          else if (i==25) then
            ! AFTER CHANGREF: change of reference frame
            write (16, *) ' TYPE CODE:CHANGREF *********************'
            call chrefe
          else if (i==26) then
            ! After TOF:
            ! ---  the T.O.F may be activated in the dynamics of bunchers, cavities and acc. gaps
            ! ---  Entry: indic and icor
            ! ---  indic = 0 : the T.O.F is activated, otherwise it is passive
            ! ---  icor = 0  : no adjustement on the phase offset, otherwise adjustments are automatically made on the
            ! phase offset
            write (16, *) ' TYPE CODE: TOF ************'
            call rmami
            write (16, *) '****************************'
          else if (i==27) then
            ! AFTER REJECT: defining limits in X,X',Y,Y',Z,Z'
            ! ---- aperture of the Beam
            ! ----  WDISP: in half dispersion
            ! ------  IF IFW=0  ==> WDISP in (+-) dW/W
            ! ------  IF IFW=1  ==> WDISP in (+-) dW (MeV)
            ! ------  IF IFW=10 ==> wdisp = dW/W relative to REF
            ! ------  IF IFW=11 ==> wdisp = dW relative to REF
            ! ----  WPHAS: in half phase (+-) deg
            ! ----  WX   : in x-direction (+-) cm
            ! ----  WY   : in y-direction (+-) cm
            ! ----  RLIM : in radius (cm)
            write (16, *) ' TYPE CODE:REJECT*********************'
            read (in, *) ifw, wdisp, wphas, wx, wy, rlim
            if (ifw==0) then
              write (16, 1050) wdisp, wphas, wx, wy, rlim
            else
              write (16, 1051) wdisp, wphas, wx, wy, rlim
            end if
1050        format (5x, ' *** BEAM SIZE LIMITS ', /, 4x, ' 1/2 dW/W :', e12.5, '  1/2 PHASE(DEG) :', e12.5, /, 4x, &
              ' 1/2 x (cm) :', e12.5, ' 1/2 y(cm) :', e12.5, ' RADIUS (cm) :', e12.5)
1051        format (5x, ' *** BEAM SIZE LIMITS ', /, 4x, '1/2 dW (MeV) :', e12.5, '  1/2 PHASE(DEG) :', e12.5, /, 4x, &
              ' 1/2 x (cm) :', e12.5, ' 1/2 y(cm) :', e12.5, ' RADIUS (cm) :', e12.5)
            ! ---- convert WPHAS in rad
            wphas = wphas*pi/180.
            write (16, *) '****************************'
          else if (i==28) then
            ! AFTER ZROT : beam rotation
            ! The transverse coordinates x and y may be rotated through an
            ! angle ZROTA(deg).The positive sense of ratation is clockwise
            ! about the positive z axis
            write (16, *) ' TYPE CODE:ZROT*********************'
            read (in, *) zrota
            call zrotat(zrota)
            write (16, *) '****************************'
          else if (i==29) then
            ! after ALINER: ALIGNMENT errors IN X,X',Y,Y'
            ! XL,YL (cm)    XPL,YPL (mrad)
            write (16, *) ' TYPE CODE:ALINER*********************'
            read (in, *) xl, yl, xpl, ypl
            call aliner
            write (16, *) '****************************'
          else if (i==30) then
            ! AFTER ACCEPT: Determination of the input acceptance for the structure
            write (16, *) ' TYPE CODE:ACCEPT*********************'
            acpt = .true.
            call accept
            acpt = .false.
            write (16, *) '****************************'
          else if (i==31) then
            ! AFTER EMIT  Print emittance data in the file 'dynac.short'
            call emiprt(0)
          else if (i==32) then
            ! AFTER EMITGR: emittance plots
            ! PLOTS IN XX', YY', XY AND ZZ'
            write (16, *) ' TYPE CODE:EMITGR*********************'
            igrprm = 0
            call ytzp
            write (16, *) '****************************'
          else if (i==33) then
            ! AFTER COMMENT
            ! allows for comments in the input data file
            write (16, '(a8)') kley
            read (in, '(A)') cmnt(1:80)
            write (16, '(A)') cmnt(1:80)
          else if (i==34) then
            ! AFTER WRBEAM: prints coordinates of particles on output files
            write (16, *) 'WRBEAM output coordinates of particles'
            ! irec:flag   irec=0 the phase is recentered with regard to the c.o.g
            ! irec<>0 the phase is not recentered around the c.o.g
            read (in, '(A)') wfile
            write (16, '(A)') 'Distribution will be written to ', wfile
            read (in, *) irec, iflg
            ! iflag=0
            call prbeam(iflg, wfile)
            write (16, *) '****************************'
          else if (i==35) then
            ! AFTER ENVEL: plot the longitudinal and the tranverse envelope of the beam
            write (16, *) ' ENVEL *********************'
            call profil
            write (16, *) '****************************'
          else if (i==36) then
            ! AFTER CHASE:Temporary elimination of most distant particles for statistical purposes
            write (16, *) ' TYPE CODE:CHASE ********************'
            call chase
            write (16, *) '****************************'
          else if (i==37) then
            ! AFTER RWFIELD : rewinds the file 'field.txt'
            rewind(20)
          else if (i==38) then
            ! AFTER RANDALI : generates random errors in alignments
            ! XL,YL (cm)    XPL,YPL (mrad)
            ! ilier = 0 stop the effects of the random misalignment
            write (16, *) ' TYPE CODE:RANDALI*********************'
            read (in, *) ilier
            if (ilier==0) then
              ialin = .false.
              write (16, *) '****************************'
              ! go to 200
            else
              ialin = .true.
              read (in, *) xl, yl, xpl, ypl
            end if
            write (16, *) '****************************'
          else if (i==39) then
            ! AFTER TWQA generates systematic or random twist of quadrupoles
            ! QTWIST: rotation about Y axis (deg)
            ! IQRAND: =0 systematic twist, otherwise random twist
            write (16, *) ' TYPE CODE TWQA*********************'
            read (in, *) iqrand, qtwist
            itwist = .true.
            if (abs(qtwist)<=1.e-20) itwist = .false.
            write (16, *) '****************************'
          else if (i==40) then
            ! AFTER EMIPRT : print the beam characteristics in the disk(tape12, file='dynac.short')
            ! --- the beam characteristics are systematically print after:
            ! cavities, accelerating gaps, bunchers, electrons gun, rfq

            ! IEMQESG :  =0  stop the prints for all optical lenses
            ! =1  after all optical lenses apart from positive drifts
            ! =2  after all optical lenses and positive drifts
            ! =3  after quads, solen.,positive drifts and accel. elements
            iemgrw = .true.
            read (in, *) iemqesg
            if (iemqesg==0) iemgrw = .false.
          else if (i==41) then
            ! AFTER MMODE: systematic or random error on the phase offset and on the level of the field
            ! ---          MMODE is only acting on  particles in the bunch  (no change of the reference)
            ! --- ENTRY: ierpf , vphase , vfield
            ! --- ierpf: flag
            ! ---   IF:  ierpf = 0  ===> stop the type code effects
            ! ---        ierpf = 1  ===> systematic error
            ! ---        ierpf > 1  ===> random error
            ! ---  vphase (deg): error added to the nominal phase offset
            ! ---  vfield (%)  : error added to the level of the electric field
            ! ---  (new phase offset) = (previous phase offset) + vphase
            ! ---  (new level of field) = (previous level of field) * (1.+ vfield/100)
            write (16, *) ' TYPE CODE MMODE*********************'
            read (in, *) ierpf, vphase, vfield
            if (ierpf==0) then
              vphase = 0.
              vfield = 0.
            end if
            if (ierpf==1) write (16, 4279) vphase, vfield
4279        format (2x, 'systematic error on phase offset: ', e12.2, ' deg', /, 2x, &
              'systematic error on level of field: ', e12.5, ' %')
            if (ierpf>1) write (16, 4290) vphase, vfield
4290        format (2x, 'maximun randon error on phase offset: ', e12.2, ' deg', /, 2x, &
              'maximum random error on level of field: ', e12.5, ' %')
            vfield = vfield/100.
            write (16, *) '****************************'
          else if (i==42) then
            ! --- AFTER RFQPTQ
            write (16, *) 'TYPE CODE:RFQPTQ ************************'
            write (6, *)
            ! -- ENTRIES:
            ! ---  ENTRY 1: input file 'myfile' contains the geometry of the RFQ (unit 27)
            ! ---  ENTRY 2: nceltot
            ! nceltot: number of cells (may be less than the total number of cells)
            ! ---  ENTRY 3: tvolt avolt fph
            ! ---- tvolt: factor applied to intervane-voltage Vref of the synchronous particle (in %)
            ! ---- avolt: factor applied to intervane-voltage Vpart for particles (in %)
            ! Vref = Vref(1 + tvolt/100)
            ! Vpart = Vpart(1 + avolt/100)
            ! --- fph: factor applied to the phase at entrance of cells in the file myfile  in %)
            ! (phase at entrance of cells)= (1 + fph/100) X (phase in myfile)
            ! NOTE: fph is only available for cells of type = 0, type = 2 (type = E) or type = 5 (type R)
            ! --- pib > 0:  shift the particles at the entrance of the RFQ inside (+/-) pi w.r.t.the synchronous
            ! particle
            ! --- pib = 0: no action


            ! related files:

            ! 'rfq_list.data'  : list of parameters of the RFQ

            ! 'rfq_listmid.data' : list of phases at input & middle of each RFQ cell

            ! 'rfq_lost.data'  : lists where particles are lost in the RFQ

            ! 'rfq_coeflist.data' list of coefficients
            read (in, 3333) myfile(1:80)
            write (16, *) 'RFQ input data file: ', myfile(1:80)
            open (27, file=myfile, status='unknown')
            open (70, file='rfq_list.data', status='unknown')
            open (75, file='rfq_coef.data', status='unknown')
            open (49, file='rfq_lost.data', status='unknown')
            open (89, file='rfq_listmid.data', status='unknown')
            read (in, *) nceltot
            read (in, *) tvolt, avolt, fph, pib
            write (16, 5279) nceltot, tvolt, avolt
5279        format (' RFQ number of cells: ', i5, /, '  factor on intervane voltage (reference):', e12.5, ' %', /, &
              '  factor on intervane voltage (bunch):', e12.5, ' % ')
            tvolt = tvolt/100.
            avolt = avolt/100.
            fph = (1.+fph/100.)
            if (ichaes) then
              write (16, *) '***** beam current: ', beamc, ' mA'
              if (iscsp<3) then
                write (6, *) '*** HERSC and SCHERM cannot be used in', 'the RFQ'
                write (16, *) '*** HERSC and SCHERM cannot be used in', 'the RFQ'
                stop
              end if
            end if
            call cpardyn(pib)
            write (6, *)
            write (16, *) '****************************'
          else if (i==43) then
            ! --- AFTER STRIPPER: stripper foils
            ! ---  ( based on the works of D.A. Eastham, ref.   )
            ! --- available for 'slow' hadron particles
            ! --- STRIPPER FOILS PARAMETERS:
            ! --- qs : charge (unit of charge)
            ! --- atms: atomic mass
            ! --- ths : thickness of the foils (g/cm**2)
            ! --- PARTICLES
            ! *2010-12-02 Use Baron formula for charge state distribution in case of carbon foils
            ! --- anp : atomic number of the projectile
            ! --- nqst: number of charge states after the stripper
            ! --- sqst: array holding the nsqt charge states
            ! --- qop : charge of particles after crossing the stripper foils (unit of charge)
            ! --- the atomic mass of particles (atm) is the one given in INPUT or in RDBEAM
            write (16, *) 'TYPE CODE:STRIPPER ***********************'
            read (in, *) qs, atms, ths, anp
            call stripp
            write (16, *) '****************************'
          else if (i==44) then
            ! AFTER STEER: thin steering element
            ! ---- PARAMETERS ARE INTEGRATED FIELD fld, nvf
            ! fld in units of (Tm) for magnetic steerer
            ! fld in units of (kV*m/m) for electrostatic steerer
            ! (Voltage * length / plate separation)
            ! if nvf=0,  horizontal magnetic steerer
            ! if nvf=1,  vertical magnetic steerer
            ! if nvf=2,  horzontal electrostatic steerer
            ! if nvf=3,  vertical electrostatic steerer
            write (16, *) ' TYPE CODE:STEER*********************'
            read (in, *) fld, nvf
            call steer(fld, nvf)
            write (16, *) '****************************'
            ! start of writes in file '.short' for steerer
            idav = idav + 1
            iitem(idav) = 9
            dav1(idav, 1) = fld
            dav1(idav, 2) = float(nvf)
            dav1(idav, 3) = davtot*10.
            ! end daves
          else if (i==45) then
            ! AFTER ZONES: specify zones of different colours in the bunch
            write (16, *) ' TYPE CODE:ZONES*********************'
            init = 1
            call area(init)
            write (16, *) '****************************'
          else if (i==46) then
            ! AFTER PROFGR: X-Z and Y-Z scatter plots,(X,Y,Z) and (Xp,Yp,Zp) profiles
            write (16, *) ' TYPE CODE:PROFGR*********************'
            igrprm = 0
            if (igrprm==0) then
              ! READ GRAPH TITLE
              read (in, 6620) text
6620          format (a)
              ! idwdp=0 cog=ref in XZ,YZ plots (for instance for Alvarez structure)
              ! idwdp=1 cog<>ref in XZ,YZ plots (for instance for IH structrure)
              ! iskale=0 vertical scale on profile plots is NOT a log scale
              ! iskale=1 vertical scale on profile plots IS a log scale
              read (in, *) idwdp, iskale
              ! READ GRAPH LIMITS INTO GLIM(J,K), J=GRAPH NUMBER
              ! K=1 HOR. LIMIT , K=2 VERT. LIMIT
              read (in, *) glim(3, 1), glim(3, 2), glim(4, 1), glim(4, 2)
            end if
            call grcomp(text, iskale)
            write (16, *) '****************************'
          else if (i==47) then
            ! AFTER SECORD : second order matrix for optical lenses
            write (16, *) '*****************************************'
            write (16, *) ' SECOND ORDER IN BEAM TRANSPORT**********'
            iseor = .true.
            write (16, *) '*****************************************'
          else if (i==48) then
            ! AFTER RASYN : Radiation exitation in bending magnets (only for electrons)
            write (16, *) ' SYNCHRTRON RADIATION IN BENDING MAGNET****'
            iraysh = .true.
            write (16, *) '*******************************************'
          else if (i==49) then
            ! AFTER FDRIFT : Divide a drift length in partial drifts (for space charge computations)
            write (16, *) ' TYPE CODE:FDRIFT*********************'
            ! XL    : Total drift length (cm)
            ! NPART : number of partial drifts
            ! IMIT  : if IMIT not equal zero,print emittance datas in the file 'short.txt'
            read (in, *) xl, npart, imit
            dl = xl/float(npart)
            write (16, *) ' total drift length : ', xl, ' cm divided in : ', npart, ' drifts of : ', dl, ' cm'
            call fdrift(xl, npart, imit)
            write (16, *) '*******************************************'
          else if (i==50) then
            ! AFTER FSOLE: solenoid the magnetic field is read from disk in the form (z,B(z))
            ! unities: z (m), B(z) kG
            ! BCRET : coefficient multiplier, the magnetic is: B(z) * BCRET
            ! sign field convention like in the code TRANSPORT
            write (16, *) 'TYPE CODE FSOLE*****************'
            read (in, 3333) myfile(1:80)
            ! unit 25 corresponds to an input file giving solenoid magnetic field(s) in the form (z,B(z))
            ! check if file is already open
            iostats = int(ftell(25))
            if (iostats==-1) then
              ! file not yet open
              open (25, file=myfile, status='unknown')
              write (16, *) 'Opening solenoid field file: ', myfile(1:80)
              ofelds = myfile
            else
              if (ofeldf/=myfile) then
                write (16, *) 'Closing solenoid field file: ', ofelds
                write (16, *) 'Opening solenoid field file: ', myfile(1:80)
                close (25)
                open (25, file=myfile, status='unknown')
                ofelds = myfile
              end if
            end if
            read (in, *) bcret, intgr
            write (16, 990) intgr
990         format ('*** SOLENOID WITH ARBITRARY MAGNETIC FIELD ', /, 5x, 'PARTITION IN: ', i4, ' ELEMENTARY SOLENOIDS')
            call solfield(bcret, intgr)
            write (16, *) '********************************'
          else if (i==51) then
            ! AFTER EGUN:
            ! Only the SCHEFF routine is avalaible in the routine EGUN
            ! omment       ichaes=.false.
            write (16, *) 'TYPE CODE EGUN*****************'
            ! unit 22 corresponds to an input file giving egun field (z,E(z)) E(z) normalised
            read (in, 3333) myfile(1:80)
            write (16, *) 'Egun field file: ', myfile(1:80)
            open (22, file=myfile, status='unknown')
            ! follows the particle ifpt (not active)
            ! not actived       read(in,*)ifpt
            ! fmult: field factor
            read (in, *) fmult, indp
            if (.not. ichaes) indp = 1
            ! indp: number of space charge computations to be made in the EGUN
            ! indp = 1 : 8 space charge computations. The EGUN field is divided in 16 elements
            ! indp = 2 : 16 space charge computations.                          in 32 elements
            ! indp = 3 : 32 space charge computations.                          in 64 elements
            if (ichaes) then
              write (16, *) '***** beam current: ', beamc, ' mA'
              if (iscsp<3) then
                write (6, *) '*** HERSC and SCHERM cannot be used', 'with EGUN'
                write (16, *) '*** HERSC and SCHERM cannot be used with', 'with EGUN'
                stop
              end if
            end if
            call egun(fmult, indp)
            write (16, *) '*******************************************'
          else if (i==52) then
            ! AFTER COMPRES
            ! Do so by shifting particles belonging to the same bunch outside the (+/-) pib/2 (deg) window
            ! w.r.t.the COG to inside the (+/-) pib/2 window w.r.t.the COG
            write (16, *) ' TYPE CODE: COMPRES ********'
            ! --- pib (deg)
            read (in, *) pib
            pib = pib/2.
            write (16, 1890) pib
            call compress(pib)
1890        format ('*** shift particles inside +/- ', e12.5, 'deg')
            write (16, *) '*******************************************'
          else if (i==54) then
            ! AFTER REFCOG:
            ! ISHIFT  = 0: the synchronous particle and the cog are coinciding (shift = false)
            ! ISHIFT  = 1: the synchronous particle and the cog are separated   (shift = true)
            ! ISHIFT  = 2: at the start the TOF of synchronous particle  is the TOF of the cog
            ! after synchronous particle and cog are separated (shift = true)
            ! (at the begining shift = false)
            write (16, *) ' TYPE CODE:REFCOG *********************'
            read (in, *) ishift
            if (ishift==0) then
              shift = .false.
              write (16, *) ' Synchronous particle is the COG of the', ' bunch'
              obref = vref/vl
              otref = tref
              tcog = 0.
              wcog = 0.
              do ijp = 1, ngood
                wcog = wcog + f(7, ijp)
                tcog = tcog + f(6, ijp)
              end do
              wcog = wcog/float(ngood)
              tcog = tcog/float(ngood)
              gcog = wcog/xmat
              bcog = sqrt(gcog*gcog-1.)/gcog
              vref = bcog*vl
              tref = tcog
              fcpi = fh*180./pi
              write (16, 5433) obref, otref*fcpi, vref/vl, tref*fcpi, bcog, tcog*fcpi
5433          format (' old ref. beta: ', e12.5, ' TOF: ', e12.5, ' deg', /, ' new ref. beta: ', e12.5, ' TOF: ', e12.5, &
                ' deg', /, ' COG      beta: ', e12.5, ' TOF: ', e12.5, ' deg')
              ! write(16,*) 'old TTVOL (deg): ',ottvols*fcpi
              ! write(16,*) 'new TTVOL (deg): ',ttvols*fcpi
            end if
            if (ishift==1) then
              shift = .true.
              write (16, *) ' Synchronous particle and COG of the ', 'bunch are independent'
            end if
            if (ishift>1) then
              write (16, *)
              write (16, *) ' Synchronous particle and COG of the ', &
                'bunch are independent, but initially TOF and energy', &
                'of the synchronous particle are the ones of the ', 'bunch'
              shift = .true.
              ! --- the reference is the cog
              obref = vref/vl
              otref = tref
              wcog = 0.
              tcog = 0.
              do ijp = 1, ngood
                wcog = wcog + f(7, ijp)
                tcog = tcog + f(6, ijp)
              end do
              wcog = wcog/float(ngood)
              tcog = tcog/float(ngood)
              gcog = wcog/xmat
              bcog = sqrt(gcog*gcog-1.)/gcog
              vref = bcog*vl
              tref = tcog
              ottvols = ttvols
              if (itvol) ttvols = tref
              fcpi = fh*180./pi
              ! write(16,5420)obref,otref*fcpi,obref,tref*fcpi
              write (16, 5420) obref, otref*fcpi, vref, tref*fcpi
5420          format (' old ref. beta: ', e12.5, ' tref: ', e12.5, ' deg', /, ' new ref. beta: ', e12.5, ' tref: ', &
                e12.5, ' deg')
              write (16, *) 'old TTVOL (deg): ', ottvols*fcpi
              write (16, *) 'new TTVOL (deg): ', ttvols*fcpi
            end if
            write (16, *) '****************************'
          else if (i==55) then
            ! AFTER FPART:
            ! --- a given particle is followed in the accelerating elements
            ! --- ICONT : the number of the particle followed in accelerating elements
            write (16, *) ' TYPE CODE:FPART *********************'
            read (in, *) icont
            write (16, *) ' the particle:', icont, ' is followed'
            write (16, *) '****************************'
          else if (i==56) then
            ! AFTER QUAELEC: electric quadrupole
            ! VOLT: voltage at pole tip (kV)
            ! XLQUA: effective length  (cm)
            ! RS: radial distance of pole tip from axis (cm)
            write (16, *) 'TYPE CODE:QUALEC**********'
            read (in, *) xlqua, volt, rs
            call qelec(volt, xlqua, rs)
            write (16, *) '********************************'
          else if (i==57) then
            ! AFTER QUAFK:  quadrupole (magnetic or electric)
            ! ITYQU: ITYQU = 0 electric quadrupole , otherwise magnetic quadrupole
            ! ARG: K2 (cm-2)
            ! XLQUA: effective length  (cm)
            ! RS: radial distance of pole tip from the axis (cm)
            write (16, *) 'TYPE CODE:QUAFK**********'
            read (in, *) ityqu, arg, xlqua, rs
            call qfk(ityqu, arg, xlqua, rs)
            write (16, *) '********************************'
          else if (i==58) then
            ! AFTER CAVNUM: numerical computation of multicell cavities
            ! the electromagnetic field can be read:on the disk in the form (z,E(z))
            ! or from the type code: HARM in the form of a Fourier series expansion
            write (16, *) 'TYPE CODE:CAVNUM  **********'
            call cavnum
            write (16, *) '********************************'
          else if (i==59) then
            ! AFTER EDFLEC:  ELECTROSTATIC DEFLECTOR
            ! --- Input parameters
            ! radial radius (cm)
            ! bend angle (deg)
            ! radii: vertical (radial) radii of curvature (cm)
            call e_deflec
            write (16, *) '********************************'
          else if (i==60) then
            ! AFTER EMITL  Print emittance datas in the file 'dynac.short' but
            ! also read label to written to dynac.short
            read (in, '(A)') shortl
            call emiprt(1)
          else if (i==61) then
            ! After RFKICK: Electric RF kicker
            ! PV: Voltage Factor (Voltage (kV) * electrode length (m) / gap (m))
            ! PDP: PHASE OF RF (deg)
            ! PHARM: harmonic factor (bucher fq.)/(DTL freq.)
            ! NVF: 0 = horizontal, 1 = vertical
            write (16, *) 'TYPE CODE:RFKICK ************************'
            read (in, *) pv, pdp, pharm, nvf
            plane = 'horizontal'
            if (nvf==1) plane = 'vertical  '
            write (16, 7779) pv, pdp, plane
7779        format (' RF Kicker ', /, ' Voltage Factor', e12.5, ' kV*m/m', /, ' RF Phase ', e12.5, ' deg', ' Type: ', &
              a10)
            pdp = pdp*pi/180.
            call rfkick(pv, pdp, pharm, nvf)
            write (16, *) '********************************'
          else if (i==62) then
            ! AFTER FIRORD : first order matrix for optical lenses
            write (16, *) '*****************************************'
            write (16, *) '  FIRST ORDER IN BEAM TRANSPORT**********'
            iseor = .false.
            write (16, *) '*****************************************'
          else if (i==63) then
            ! AFTER DCBEAM : select DC or bunched beam
            read (in, *) iscont
            write (16, *) '****************************'
            if (iscont==1) then
              ifcont = .true.
              write (16, *) ' DC BEAM SELECTED    **********'
            else if (iscont==0) then
              ifcont = .false.
              write (16, *) ' BUNCHED BEAM SELECTED ********'
            end if
            write (16, *) '****************************'
          else if (i==64) then
            ! AFTER T3D : request TRACE3D input file
            t3d = .true.
            write (16, *) '**************************************'
            write (16, *) '* TRACE3D INPUT FILE WILL BE WRITTEN *'
            write (16, *) '**************************************'
          else if (i==53) then
            ! AFTER STOP: mandatory, stop the computations
            write (16, 100) kle(i)
            exit
          end if
        else
          ! key not found, go to STOP
          indic = 999
          write (66, *) indic
          write (16, 111) kley
          write (6, 111) kley
          exit
        end if
      end do
      ! write trace file (if requested)
      if (t3d) then
        ! write trace file (header part)
        open (itout, file='for_trace3d.t3d', status='unknown')
        write (itout, '(A)') trace3h(1)
        write (itout, 1990) kt3t, kt3t, kt3t
1990    format (' N1= 1, N2= ', i4, ', NEL1= 1, NEL2= ', i4, ', NP1= 1, NP2= ', i4)
        do i = 2, kt3h
          write (itout, '(A)') trace3h(i)
        end do
        write (itout, 1992)
1992    format (' PQEXT= 2.5, ICHROM= 0, IBS= 0, SMAX= 2.0')
        write (itout, 1993)
1993    format (' XM=  15.00, XPM=  50.00, YM=  15.00')
        write (itout, 1994)
1994    format (' XMI= 15.00, XPMI= 50.00, XMF= 15.00, XPMF= 25.00')
        write (itout, 1995)
1995    format (' DPM=  90.0, DWM=  50.00, DPP= 90.00')
        write (itout, 1996)
1996    format (' DPMI= 90.0, DPMF= 35.00, DWMI= 50.0, DWMF= 200.0')
        ! write trace file (beam line part)

        ! deal with negative drifts (typical within DTLs)
        ! if the current drift is negative, then see if there is a drift before or
        ! after it. If so, add the 2 drifts, devide by 2 and put this result in both
        ! drifts
        do k = 2, kt3t - 1
          trdrifa = 0.
          trdrifb = 0.
          tif = trace3t(k)
          tifb = trace3t(k-1)
          tifa = trace3t(k+1)
          if (tif(12:13)==' 1' .and. tifb(12:13)==' 1') then
            read (tif(28:50), *) trdrift
            if (trdrift<0.) then
              read (tifb(28:50), *) trdrifb
              if (trdrifb>0.) then
                aver = (trdrifb+trdrift)/2.
                trdrifb = aver
                trdrift = aver
                ! write(6,*) k,'beforeb',tif(12:13),trdrift,trdrifb
                write (fdrft, 555) trdrift
555             format (f12.6)
                tif(28:40) = fdrft
                write (fdrft, 555) trdrifb
                tifb(28:40) = fdrft
                trace3t(k) = tif
                trace3t(k-1) = tifb
              end if
            end if
          else if (tif(12:13)==' 1' .and. tifa(12:13)==' 1') then
            read (tif(28:50), *) trdrift
            if (trdrift<0.) then
              read (tifa(28:50), *) trdrifa
              if (trdrifa>0.) then
                aver = (trdrifa+trdrift)/2.
                trdrifa = aver
                trdrift = aver
                ! write(6,*) k,'aftera',tif(12:13),trdrift,trdrifa
                write (fdrft, 555) trdrift
                tif(28:40) = fdrft
                write (fdrft, 555) trdrifa
                tifa(28:40) = fdrft
                trace3t(k) = tif
                trace3t(k+1) = tifa
              end if
            end if
          end if
        end do
        do k = 1, kt3t
          write (itout, '(A)') trace3t(k)
        end do
        write (itout, '(A)') ' $END'
      end if
      call daves
      call eugwrt
      call cpu_time(exfin)
      exfin = exfin - exstrt
      call mytime(iitime)
      write (6, *)
      if (mg) then
        ! using MINGW style gfortran format: 03/30/10 20:51:06 (10 is 2010)
        text(1:4) = '    '
        if (iitime(1:2)=='01') text(5:7) = 'Jan'
        if (iitime(1:2)=='02') text(5:7) = 'Feb'
        if (iitime(1:2)=='03') text(5:7) = 'Mar'
        if (iitime(1:2)=='04') text(5:7) = 'Apr'
        if (iitime(1:2)=='05') text(5:7) = 'May'
        if (iitime(1:2)=='06') text(5:7) = 'Jun'
        if (iitime(1:2)=='07') text(5:7) = 'Jul'
        if (iitime(1:2)=='08') text(5:7) = 'Aug'
        if (iitime(1:2)=='09') text(5:7) = 'Sep'
        if (iitime(1:2)=='10') text(5:7) = 'Oct'
        if (iitime(1:2)=='11') text(5:7) = 'Nov'
        if (iitime(1:2)=='12') text(5:7) = 'Dec'
        text(8:8) = ' '
        text(9:10) = iitime(4:5)
        text(11:13) = ' 20'
        text(14:15) = iitime(7:8)
        text(16:19) = ' at '
        text(20:27) = iitime(10:17)
      else
        text(1:11) = iitime(1:11)
        text(12:15) = iitime(21:24)
        text(16:19) = ' at '
        text(20:27) = iitime(12:19)
      end if
      write (12, *) 'Stopped on ', text(1:27)
      write (16, *) 'Stopped on ', text(1:27)
      write (6, '(A11,A27)') 'Stopped on ', text(1:27)
      write (6, '(A12,F14.6,A4)') 'Executed in ', exfin, ' sec'
      write (16, 101)
      ! close input files
      close (10)
      close (20)
      close (22)
      close (25)
      close (27)
      close (55)
      ! close output files
      ! files actived in the code
      close (16)
      close (12)
      close (71)
      close (50)
      close (61)
      close (60)
      close (11)
      close (66)
      close (75)
      close (49)
      ! files not actived in the code
      ! SV 24/08/2015
      close (13)
      ! old       close(14)
      ! omment       close(15)
      ! omment       close(17)
      ! omment       close(18)
      ! omment       close(19)
      ! omment       close(21)
      ! omment       close(49)
      close (70)
      stop
111   format ('STOP ON KEY: ', a8, ' (invalid key)')
100   format (/, 40x, ' STOP on key  : ', a8, //)
101   format ('*******************************************************', '*****************')
    end program dynac
    ! *******************************************************************
    ! SUBROUTINE mytime
    ! get system time and convert it to an ascii string
    ! *******************************************************************
    subroutine mytime(iitime)
      implicit real *8(a-h, o-z)
      character iitime*30
      integer *8 inttim

      inttim = time8()
      iitime = ctime(inttim)
      return
    end subroutine mytime
    ! *******************************************************************
    ! SUBROUTINE rmami
    ! activate the time of flight for bunchers, cavities and accelerating
    ! gaps
    ! - indic and icor:integer flags
    ! - itvol and imamin: logical flags
    ! - itvol = true =>   the time of flight is activated, otherwise
    ! - itvol = false =>  the time of flight is passive
    ! - imamin = true =>  adjustments are automatically made on the phase
    ! of bunchers, cavities and acc. gaps
    ! - imamin = false => no adjustments on the phase of accelerating
    ! elements
    ! - indic = 0 => itvol = true, in this case the time of flight is
    ! activited for accelerating elements
    ! - indic (<>) 0 => itvol = false and imamin = false
    ! - icor = 0 => imamin = false
    ! - icor (<>) 0 => imamin = true
    ! *******************************************************************
    subroutine rmami
      implicit real *8(a-h, o-z)
      parameter(maxcell1=3000)
      common /tapes/in, ifile, meta
      common /dyn/tref, vref
      common /ttfc/tk, t1k, t2k, sk, s1k, s2k, fh
      common /consta/vl, pi, xmat, rpel, qst
      common /davcom/dav1(maxcell1, 40), davtot, iitem(maxcell1), idav
      common /itvole/itvol, imamin
      common /tofev/ttvols
      logical itvol, imamin

      fcpi = fh*180./pi
      ttvols = 0.
      read (in, *) indic, icor
      if (indic==0) then
        itvol = .true.
        ttvols = tref
        write (16, 10) ttvols*fcpi, davtot, tref*fcpi
      else
        itvol = .false.
        write (16, *) 'time of flight passive '
      end if
10    format (' ** time of flight activated at: ', e12.5, ' deg at position: ', e12.5, ' cm in the lattice', /, 3x, &
        'tof of the reference: ', e12.5, ' deg')
      imamin = .false.
      if (itvol .and. icor/=0) imamin = .true.
      if (imamin) write (16, *) ' Adjustments on phase offset of acc. elements'
      if (.not. imamin) write (16, *) ' No adjustments on phase offset'
      return
    end subroutine rmami
    ! *******************************************************************
    ! SUBROUTINE kick
    ! 2015 now obsolete (?) see subroutine aliner
    ! *******************************************************************
    ! SUBROUTINE kick
    ! implicit real*8 (a-h,o-z)
    ! C     ..................................
    ! C     ALIGNMENT DEFAULTS :
    ! C       HORIZONTAL : XL(cm)
    ! C       VERTICAL   : YL(cm)
    ! C     ..................................
    ! parameter (iptsz=100002,maxcell=3000,maxcell1=3000)
    ! COMMON/DESA/XL,YL,IFLAG
    ! common/faisc/f(10,iptsz),imax,ngood
    ! WRITE(16,100) XL,YL
    ! 100    FORMAT(/,5X,' KICK x(cm) y(cm): ',2(e12.5,2x),/)
    ! C         CM-MRD
    ! DO II=1,ngood
    ! if(iflag.ne.1) then
    ! F(2,II)=F(2,II) + XL
    ! F(4,II)=F(4,II) + YL
    ! else
    ! C           F(2,II)=F(2,II) - XL
    ! F(4,II)=F(4,II) - YL
    ! endif
    ! enddo
    ! RETURN
    ! END
    ! *******************************************************************
    ! SUBROUTINE shuffle
    ! Reshuffles f(i,j) array so that the "good" particles are on top of
    ! the stack.  The number of "good" particles (ngood) is passed back.
    ! *******************************************************************
    subroutine shuffle
      implicit real *8(a-h, o-z)
      parameter(iptsz=100002, maxcell=3000, maxcell1=3000)
      common /faisc/f(10, iptsz), imax, ngood
      common /mcs/imcs, ncstat, cstat(20)
      common /macro/ratei

      k = ngood
      ngood1 = 0
1     if (ngood1>=k) go to 5
      if (f(8,ngood1+1)==1.) go to 4
      do j = 1, 10
        c = f(j, ngood1+1)
        f(j, ngood1+1) = f(j, k)
        f(j, k) = c
      end do
      k = k - 1
      go to 1
4     ngood1 = ngood1 + 1
      go to 1
5     continue
      ngood = ngood1
      if (ngood==0) then
        ratei = 0.
      else
        ratei = float(imax)/float(ngood)
      end if
      ! *ets*2015/05/20
      ncstat = 1
      cstat(1) = f(9, 1)
      do j = 2, ngood
        mcstat = 0
        do k = 1, ncstat
          if (f(9,j)==cstat(k)) then
            mcstat = 1
          end if
        end do
        if (mcstat==0) then
          ncstat = ncstat + 1
          cstat(ncstat) = f(9, j)
        end if
      end do
      write (16, *) 'Number of charge states after shuffle: ', ncstat
      write (16, *) 'Charge states: ', (cstat(j), j=1, ncstat)
      imcs = 0
      if (ncstat>1) imcs = 1
      ! *ete*2015/05/20
      ! omment       write(16,*) '***reshuffle: ',ngood,' good particles'
      if (ngood<10) then
        write (16, *) 'Less than 10 particles left, statistics too low'
        write (6, *)
        write (6, *) 'Less than 10 particles left, statistics too low'
        stop
      end if
      return
    end subroutine shuffle
    ! *******************************************************************
    ! FUNCTION xitl0(GAMI,GAMS,BETR,SAPHI,QQC)
    ! called by RESTAY and ETGAP  dynamics computations
    ! *******************************************************************
    function xitl0(gami, gams, betr, saphi, qqc)
      implicit real *8(a-h, o-z)
      common /consta/vl, pi, xmat, rpel, qst
      common /ttfc/tk, t1k, t2k, sk, s1k, s2k, fh
      common /bedycp/phslip, eqvl, asdl, peqvl, pavph, xkp1, xkp2, aa, bb, cc, dd, ee, pcrest, sqcttf

      fh0 = fh/vl
      cgi = qqc/xmat
      beti = sqrt(1.-1./(gami*gami))
      bets = sqrt(1.-1./(gams*gams))
      xk1 = fh0/beti
      xk2 = fh0/bets
      xkm = fh0/betr
      tilta2 = phslip/(2.*eqvl)
      pavph = 1./10.*(xk1-xk2)*eqvl + (xk1-xkm)*asdl
      xkc1 = -fh0/(beti**3*gami**3)
      xkc2 = -fh0/(bets**3*gams**3)
      do i = 1, 2
        phit10 = saphi - phslip/2. + pavph
        daz0 = cos(phit10)*tilta2
        dbz0 = sin(phit10)*tilta2
        dgz0 = cgi*(tk*daz0-sk*dbz0)
        dgz0 = dgz0/sin(phslip/2.)
        xkp1 = xkc1*dgz0
        phit11 = saphi + phslip/2. + pavph
        daz1 = cos(phit11)*tilta2
        dbz1 = sin(phit11)*tilta2
        dgz1 = cgi*(tk*daz1-sk*dbz1)
        dgz1 = dgz1/sin(phslip/2.)
        xkp2 = xkc2*dgz1
        pavph = 1./10.*(xk1-xk2)*eqvl + (xk1-xkm)*asdl
        pavph = pavph + (xkp1+xkp2)*eqvl**2/120.
      end do
      xk11 = xk1 - xkm
      xk22 = xk2 - xkm
      aa = xk11
      bb = xkp1/2.
      ccl1 = -(4.*xk22+6.*xk11)/(eqvl**2)
      ccl2 = -(3./2.*xkp1-xkp2/2.)/eqvl
      cc = ccl1 + ccl2
      ddl1 = (7.*xk22+8.*xk11)/(eqvl**3)
      ddl2 = (3./2.*xkp1-xkp2)/(eqvl**2)
      dd = ddl1 + ddl2
      eel1 = -(3.*xk22+3.*xk11)/(eqvl**4)
      eel2 = -(xkp1/2.-xkp2/2.)/(eqvl**3)
      ee = eel1 + eel2
      phit0 = saphi + pavph
      git = cgi*(tk*cos(phit0)-sk*sin(phit0))
      xitl0 = gami + git
      return
    end function xitl0
    ! *******************************************************************
    ! FUNCTION xitl2(GAMI,GAMS,BETR,SAPHI,QQC)
    ! called by RESTAY and ETGAP
    ! INTEGRAL of S ( EZG * Z/(BETA*GAMA)**3  *DZ)
    ! PHASE JUMP
    ! *******************************************************************
    function xitl2(gami, gams, betr, saphi, qqc)
      implicit real *8(a-h, o-z)
      common /consta/vl, pi, xmat, rpel, qst
      common /ttfc/tk, t1k, t2k, sk, s1k, s2k, fh
      common /bedycp/phslip, eqvl, asdl, peqvl, pavph, xkp1, xkp2, aa, bb, cc, dd, ee, pcrest, sqcttf
      dimension h(8), t(8)
      data h/.101228536, .222381034, .313706646, .362683783, .362683783, .313706646, .222381034, .101228536/
      data t/ -.960289856, -.796666477, -.525532409, -.183434642, .183434642, .525532409, .796666477, .960289856/

      fh0 = fh/vl
      cgi = qqc/xmat
      xitl2 = 0.
      beti = sqrt(1.-1./(gami*gami))
      bets = sqrt(1.-1./(gams*gams))
      xk1 = fh0/beti
      xk2 = fh0/bets
      xkm = fh0/betr
      tilta2 = phslip/(2.*eqvl)
      do i = 1, 8
        xcc = eqvl*(1.+t(i))/2.
        phit0 = saphi - phslip*(eqvl-xcc)/(2.*eqvl) + pavph
        git = cgi*(tk*cos(phit0)-sk*sin(phit0))
        gi = gami + git*sin(xcc*tilta2)/sin(phslip/2.)
        bi = sqrt(1.-1./(gi*gi))
        phit1 = phit0 + xcc*phslip/(2.*eqvl)
        daz = cos(phit1)*tilta2
        dbz = sin(phit1)*tilta2
        dgz = cgi*(tk*daz-sk*dbz)
        dgz = dgz/sin(phslip/2.)
        ez = xmat/qqc*dgz
        xint = 1./(bi*gi)
        xcc1 = xcc + asdl
        xitl2 = xitl2 + h(i)*xint**3*xcc1*ez
      end do
      xitl2 = xitl2/2.*eqvl
      return
    end function xitl2
    ! *******************************************************************
    ! FUNCTION xitl3(GAMI,GAMS,BETR,NIT,SAPHI,QQC)
    ! called by RESTAY and ETGAP
    ! INTEGRAL  S ( EZG * Z/(BETA*GAMA)**3  *DZ)
    ! PHASE AND ENERGY AT THE MIDDLE OF THE GAP
    ! *******************************************************************
    function xitl3(gami, gams, betr, nit, saphi, qqc)
      implicit real *8(a-h, o-z)
      common /consta/vl, pi, xmat, rpel, qst
      common /ttfc/tk, t1k, t2k, sk, s1k, s2k, fh
      common /bedycp/phslip, eqvl, asdl, peqvl, pavph, xkp1, xkp2, aa, bb, cc, dd, ee, pcrest, sqcttf
      common /midgap/enmil, vapmi
      common /gaus13/h(13), t(13)
      common /sgcos/xkpc

      fh0 = fh/vl
      cgi = qqc/xmat
      xitl3 = 0.
      beti = sqrt(1.-1./(gami*gami))
      bets = sqrt(1.-1./(gams*gams))
      xk1 = fh0/beti
      xk2 = fh0/bets
      xkm = fh0/betr
      xk11 = xk1 - xkm
      tilta2 = phslip/(2.*eqvl)
      do i = 1, 13
        xcc = eqvl*(1.+t(i))/2.
        phit0 = saphi - phslip*(eqvl-xcc)/(2.*eqvl) + pavph
        git = cgi*(tk*cos(phit0)-sk*sin(phit0))
        gi = gami + git*sin(xcc*tilta2)/sin(phslip/2.)
        bi = sqrt(1.-1./(gi*gi))
        phit1 = phit0 + xcc*phslip/(2.*eqvl)
        daz = cos(phit1)*tilta2
        dbz = sin(phit1)*tilta2
        dgz = cgi*(tk*daz-sk*dbz)
        dgz = dgz/sin(phslip/2.)
        ez = xmat/qqc*dgz
        xint = 1./(bi*gi)
        xcc1 = xcc + asdl
        xitl3 = xitl3 + h(i)*xint**3*xcc1*ez
        ! ENERGY AND PHASE AT THE MIDDLE OF THE GAP
        if (nit==3 .and. i==7) then
          ! ENMIL=XMAT*(GI-GAMI)
          enmil = xmat*(gi-1.)
          vapmi = (xk11*asdl+saphi+xkm*xcc1+aa*xcc+bb*xcc*xcc+cc*xcc**3+dd*xcc**4+ee*xcc**5)*180./pi
        end if
      end do
      xitl3 = xitl3/2.*eqvl
      return
    end function xitl3
    ! *******************************************************************
    ! SUBROUTINE xtypl2(GAMI,SAPHI,QSC,DCG)
    ! called by RESTAY and ETGAP
    ! integrals of the second derivative of the functions HA0(z) and HB0(z)
    ! ZB = Z+ASDL
    ! *******************************************************************
    subroutine xtypl2(gami, saphi, qsc, dcg)
      implicit real *8(a-h, o-z)
      common /consta/vl, pi, xmat, rpel, qst
      common /ttfc/tk, t1k, t2k, sk, s1k, s2k, fh
      common /bedycp/phslip, eqvl, asdl, peqvl, pavph, xkp1, xkp2, aa, bb, cc, dd, ee, pcrest, sqcttf
      common /thad2/h0aki, h0akim, h0akm, h0bki, h0bkim, h0bkm, h1aki, h1akim, h1akm, h1bki, h1bkim, h1bkm
      common /gaus17/h1(17), t1(17)

      fh0 = fh/vl
      cgi = qsc/xmat
      gam2 = gami**2
      beti = sqrt(1.-1./gam2)
      xk1 = fh0/beti
      ! circular functions in cos
      h0aki = 0.
      h0akim = 0.
      h0akm = 0.
      h1aki = 0.
      h1akim = 0.
      h1akm = 0.
      ! circular functions in sin
      h0bki = 0.
      h0bkim = 0.
      h0bkm = 0.
      h1bki = 0.
      h1bkim = 0.
      h1bkm = 0.

      dtilk = eqvl
      tilta2 = phslip/(2.*eqvl)
      cgam10 = ((gami*gami-1.)**3)/(fh0*fh0)
      dgam10 = gami*((gami*gami-1.)**2)/(fh0*fh0)
      phcrtk = (t1k*sk-s1k*tk)/(tk*tk+sk*sk)
      dphc1 = (t2k*sk-s2k*tk)/(tk*tk+sk*sk)
      dphc2 = (t1k*tk+s1k*sk)*(t1k*sk-s1k*tk)/((tk*tk+sk*sk)**2)
      dphcrtk = dphc1 - 2.*dphc2
      bim1 = beti
      gakm1 = 0.
      gait = gami
      do i = 1, 17
        xcc = eqvl*(1.+h1(i))/2.
        xcc1 = xcc + asdl
        if (xcc1>dcg) go to 200
        phit0 = saphi - phslip*(eqvl-xcc)/(2.*eqvl) + pavph
        ! Function GAMMA (Z)
        if (phslip/=0.) then
          git = cgi*sqcttf*cos(phit0-pcrest)/phslip
          gis = sin(xcc*tilta2)
        else
          git = cgi*sqcttf*cos(phit0-pcrest)
          gis = xcc/(2.*eqvl)
        end if
        gitc = git*gis
        gi = gami + git*gis
        bi = sqrt(1.-1./(gi*gi))
        ! FONCTION DERIVE G0(Z) RELATIF A K MOYEN
        phit0k = -dtilk*(1.-xcc/eqvl)/2.
        ! DERIVE PREMIERE FONGTION GAMMA
        if (phslip/=0.) then
          gic = cos(xcc*tilta2)
          gak1 = dtilk*cos(phit0-pcrest)*gis/(phslip*phslip)
          gak2 = sin(phit0-pcrest)*gis*(phit0k-phcrtk)/phslip
          gak3 = dtilk*cos(phit0-pcrest)*xcc*gic/(2.*phslip*eqvl)
          gak = cgi*sqcttf*(-gak1-gak2+gak3)
        else
          gak1 = sin(phit0-pcrest)*gis*(phit0k-phcrtk)
          gak = -cgi*sqcttf*gak1
        end if
        ! Second derivative of GAMMA(z)
        if (gi/=gait) then
          dgak = (gak-gakm1)/(gi-gait)*gak
        else
          dgak = 0.
        end if
        gakm1 = gak
        gait = gi
        xcc1 = xcc + asdl
        phit1 = phit0 + xcc*phslip/(2.*eqvl)
        phtz0 = (xcc/eqvl-.5)*dtilk
        dphtz0 = dtilk/eqvl
        phcrz0 = (phtz0-phcrtk)
        ! INTEGRALES FONCTIONS HAKI(Z) (a multipler par (k1i-k10)**2 )
        haki1 = sqcttf*cos(phit1-pcrest)/((gi*gi-1.)**2.5)
        haki2 = sqcttf*cos(phit1-pcrest)*gi/((gi*gi-1.)**2.5)
        haki3 = sqcttf*cos(phit1-pcrest)*gi*gi/((gi*gi-1.)**3.5)
        ! n=0
        h0aki = h0aki + t1(i)*cgam10*(-3.*haki1+15*haki3) - t1(i)*dgam10*9.*haki2
        ! n=1
        h1aki = h1aki + t1(i)*cgam10*xcc1*(-3.*haki1+15.*haki3) - t1(i)*dgam10*9.*haki2*xcc1
        ! Integral of HAKIM(Z) (to be multiplied by (k1i-k10)*(kmi-km0) )
        hakim1 = sqcttf*cos(phit1-pcrest)*gak/((gi*gi-1.)**2.5)
        hakim2 = sqcttf*cos(phit1-pcrest)*gi*gi*gak/((gi*gi-1.)**3.5)
        hakim2 = hakim2
        hakim3 = sqcttf*sin(phit1-pcrest)*gi/((gi*gi-1.)**2.5)
        ! n=0
        h0akim = h0akim + t1(i)*sqrt(cgam10)*(6.*hakim1-30.*hakim2-3.*phcrz0*hakim3)
        ! n=1
        h1akim = h1akim + t1(i)*sqrt(cgam10)*(6.*hakim1-30.*hakim2-3.*phcrz0*hakim3)*xcc1
        ! Integral of HAKM(Z) (to be multiplied by (kmi-km0)**2  )
        hakm1 = sqcttf*cos(phit1-pcrest)*gak*gak/((gi*gi-1.)**2.5)
        hakm2 = sqcttf*cos(phit1-pcrest)*dgak*gi/((gi*gi-1.)**2.5)
        hakm3 = sqcttf*cos(phit1-pcrest)*gak*gak*gi*gi/((gi*gi-1.)**3.5)
        hakm4 = sqcttf*sin(phit1-pcrest)*gak*gi/((gi*gi-1.)**2.5)
        hakm5 = sqcttf*cos(phit1-pcrest)/((gi*gi-1.)**1.5)
        hakm6 = sqcttf*sin(phit1-pcrest)/((gi*gi-1.)**1.5)
        ! n=0
        h0akm = h0akm + t1(i)*(-3.*hakm1-3.*hakm2+15.*hakm3+3.*phcrz0*hakm4-phcrz0*phcrz0*hakm5+dphcrtk*hakm6)
        ! n=1
        h1akm = h1akm + t1(i)*xcc1*(-3.*hakm1-3.*hakm2+15.*hakm3+3.*phcrz0*hakm4-phcrz0*phcrz0*hakm5+dphcrtk*hakm6)

        ! INTEGRALES FONCTIONS HBKI(Z) (a multipler par (k1i-k10)**2 )
        hbki1 = sqcttf*sin(phit1-pcrest)/((gi*gi-1.)**2.5)
        hbki2 = sqcttf*sin(phit1-pcrest)*gi/((gi*gi-1.)**2.5)
        hbki3 = sqcttf*sin(phit1-pcrest)*gi*gi/((gi*gi-1.)**3.5)
        ! n=0
        h0bki = h0bki + t1(i)*cgam10*(-3.*hbki1+15.*hbki3) - t1(i)*dgam10*9.*hbki2
        ! n=1
        h1bki = h1bki + t1(i)*cgam10*xcc1*(-3.*hbki1+15.*hbki3) - t1(i)*dgam10*9.*hbki2*xcc1
        ! Integral of HBKIM(Z) (to be multiplied by (k1i-k10)*(kmi-km0) )
        hbkim1 = sqcttf*sin(phit1-pcrest)*gak/((gi*gi-1.)**2.5)
        hbkim2 = sqcttf*sin(phit1-pcrest)*gi*gi*gak/((gi*gi-1.)**3.5)
        hbkim2 = hbkim2
        hbkim3 = sqcttf*cos(phit1-pcrest)*gi/((gi*gi-1.)**2.5)
        ! n=0
        h0bkim = h0bkim + t1(i)*sqrt(cgam10)*(6.*hakim1-30.*hakim2+3.*phcrz0*hakim3)
        ! n=1
        h1bkim = h1bkim + t1(i)*sqrt(cgam10)*(6.*hakim1-30.*hakim2+3.*phcrz0*hakim3)*xcc1
        ! Integral of HBKM(Z) (to be multiplied by (kmi-km0)**2  )
        hbkm1 = sqcttf*sin(phit1-pcrest)*gak*gak/((gi*gi-1.)**2.5)
        hbkm2 = sqcttf*sin(phit1-pcrest)*dgak*gi/((gi*gi-1.)**2.5)
        hbkm3 = sqcttf*sin(phit1-pcrest)*gak*gak*gi*gi/((gi*gi-1.)**3.5)
        hbkm4 = sqcttf*cos(phit1-pcrest)*gak*gi/((gi*gi-1.)**2.5)
        hbkm5 = sqcttf*sin(phit1-pcrest)/((gi*gi-1.)**1.5)
        hbkm6 = sqcttf*cos(phit1-pcrest)/((gi*gi-1.)**1.5)
        ! n=0
        h0bkm = h0bkm + t1(i)*(-3.*hbkm1-3.*hbkm2+15.*hbkm3-3.*phcrz0*hbkm4-phcrz0*phcrz0*hbkm5-dphcrtk*hbkm6)
        ! n=1
        h1bkm = h1bkm + t1(i)*xcc1*(-3.*hbkm1-3.*hbkm2+15.*hbkm3-3.*phcrz0*hbkm4-phcrz0*phcrz0*hbkm5-dphcrtk*hbkm6)
      end do
200   continue
      ! integrals in cos
      h0aki = h0aki/2.*eqvl
      h0akim = h0akim/2.*eqvl
      h0akm = h0akm/2.*eqvl
      h1aki = h1aki/2.*eqvl
      h1akim = h1akim/2.*eqvl
      h1akm = h1akm/2.*eqvl
      ! integrals in sin
      h0bki = h0bki/2.*eqvl
      h0bkim = h0bkim/2.*eqvl
      h0bkm = h0bkm/2.*eqvl
      h1bki = h1bki/2.*eqvl
      h1bkim = h1bkim/2.*eqvl
      h1bkm = h1bkm/2.*eqvl
      return
    end subroutine xtypl2
    ! *******************************************************************
    ! SUBROUTINE xtyplp1(GAMI,SAPHI,QSC,DCG)
    ! called by RESTAY and ETGAP
    ! Integrals of functions  HA0(Z) and HB0(Z)
    ! Integrals of the first and second derivative of HA0(Z) et HB0(Z)(with PH01)
    ! Integrals of the third derivative of HA0(Z) et HB0(Z)(with PH01)
    ! zb = z+ASDL
    ! *******************************************************************
    subroutine xtyplp1(gami, saphi, qsc, dcg)
      implicit real *8(a-h, o-z)
      common /consta/vl, pi, xmat, rpel, qst
      common /jacob/gaks, gaps
      common /ttfc/tk, t1k, t2k, sk, s1k, s2k, fh
      common /bedycp/phslip, eqvl, asdl, peqvl, pavph, xkp1, xkp2, aa, bb, cc, dd, ee, pcrest, sqcttf
      common /typlp1/yh1p1, yh2p1, hapi, hbpi
      common /typlp2/happi, hbppi
      common /gaus17/h1(17), t1(17)

      fh0 = fh/vl
      cgi = qsc/xmat
      gam2 = gami**2
      beti = sqrt(1.-1./gam2)
      xk1 = fh0/beti
      dtilk = eqvl
      ! circular functions in cos
      yh1p1 = 0.
      hapi = 0.
      happi = 0.
      ! circular functions in sin
      yh2p1 = 0.
      hbpi = 0.
      hbppi = 0.
      tilta2 = phslip/(2.*eqvl)
      if (phslip/=0.) desy = phslip/sin(phslip/2.)
      if (phslip==0.) desy = 2.
      do i = 1, 17
        xcc = eqvl*(1.+h1(i))/2.
        xcc1 = xcc + asdl
        if (xcc1>dcg) go to 200
        phit0 = saphi - phslip*(eqvl-xcc)/(2.*eqvl) + pavph
        ! FONCTION GAMMA (Z)
        if (phslip/=0.) then
          git = cgi*sqcttf*cos(phit0-pcrest)/phslip
          gis = sin(xcc*tilta2)
        else
          git = cgi*sqcttf*cos(phit0-pcrest)
          gis = xcc/(2.*eqvl)
        end if
        gi = gami + git*gis
        bi = sqrt(1.-1./(gi*gi))
        ! FONCTION DERIVE G0(Z) RELATIF A PH01
        if (phslip/=0.) then
          gap = -cgi*sqcttf*sin(phit0-pcrest)*gis/phslip
          ! DERIVE TROISIEME
          ddgap = -gap
        else
          gap = sin(phit0-pcrest)*gis
          gap = -cgi*sqcttf*gap
          ddgap = -gap
        end if
        if (i==17) gaps = gap
        ! Second derivative of G0(Z) in relation with  PH01
        if (phslip/=0.) then
          dgap = -cgi*sqcttf*cos(phit0-pcrest)*gis/phslip
        else
          dgap = cos(phit0-pcrest)*gis
          dgap = -cgi*sqcttf*dgap
        end if
        ! INTEGRALES FONCTIONS HA0(Z) et HB0(Z)
        xint = 1./(bi*bi*bi*gi*gi*gi)
        phit1 = phit0 + xcc*phslip/(2.*eqvl)
        phtz0 = (xcc/eqvl-.5)*dtilk
        ! INTEGRALES DERIVES HA0(Z)
        dha01 = sqcttf*cos(phit1-pcrest)*gi*gap/((gi*gi-1.)**2.5)
        dha02 = 0.
        ! n=1
        yh1p1 = yh1p1 + t1(i)*xcc1*(-6.*dha01-2.*dha02)
        ! INTEGRALES DERIVES  HB0(Z)
        dhb01 = sqcttf*sin(phit1-pcrest)*gi*gap/((gi*gi-1.)**2.5)
        dhb02 = 0.
        ! n=1
        yh2p1 = yh2p1 + t1(i)*xcc1*(-6.*dhb01+2.*dhb02)
        ! INTEGRALES HAPI(Z) (multiplies par (ph1i-ph10)**2 )
        hapi1 = sqcttf*cos(phit1-pcrest)*gap*gap/((gi*gi-1.)**2.5)
        hapi2 = sqcttf*cos(phit1-pcrest)*gi*dgap/((gi*gi-1.)**2.5)
        hapi3 = sqcttf*cos(phit1-pcrest)*gi*gi*gap*gap/((gi*gi-1.)**3.5)
        ! n=1
        hapi = hapi + t1(i)*xcc1*(-3.*hapi1-3.*hapi2+15.*hapi3)
        ! INTEGRALES HAPPI(Z) (multiplies par (ph1i-ph10)**3 )/3
        happi1 = sqcttf*cos(phit1-pcrest)*gap*dgap/((gi*gi-1.)**2.5)
        happi2 = sqcttf*cos(phit1-pcrest)*gap*gap*gap*gi/((gi*gi-1.)**3.5)
        happi3 = sqcttf*cos(phit1-pcrest)*gap*dgap/((gi*gi-1.)**2.5)
        happi4 = sqcttf*cos(phit1-pcrest)*gi*ddgap/((gi*gi-1.)**2.5)
        happi5 = sqcttf*cos(phit1-pcrest)*gi*gi*gap*dgap/((gi*gi-1.)**3.5)
        happi6 = sqcttf*cos(phit1-pcrest)*gi*gap**3/((gi*gi-1.)**3.5)
        happi7 = sqcttf*cos(phit1-pcrest)*gi*gi*dgap*gap/((gi*gi-1.)**3.5)
        happi8 = sqcttf*cos(phit1-pcrest)*gi*gi*gi*gap*gap*gap/((gi*gi-1.)**4.5)
        ! n=1
        happi = happi + t1(i)*xcc1*(-6.*happi1+15.*happi2-3.*happi3-3.*happi4+15.*happi5+30.*happi6+30.*happi7-105.* &
          happi8)

        ! INTEGRAL OF HBPI(Z) (to be multiplied by (ph1i-ph10)**2 )
        hbpi1 = sqcttf*sin(phit1-pcrest)*gap*gap/((gi*gi-1.)**2.5)
        hbpi2 = sqcttf*sin(phit1-pcrest)*gi*dgap/((gi*gi-1.)**2.5)
        hbpi3 = sqcttf*sin(phit1-pcrest)*gi*gi*gap*gap/((gi*gi-1.)**3.5)
        ! n=1
        hbpi = hbpi + t1(i)*xcc1*(-3.*hbpi1-3.*hbpi2+15.*hbpi3)
        ! INTEGRALS of HBPPI(Z) (to be multiplied by(ph1i-ph10)**3 )/3
        hbppi1 = sqcttf*sin(phit1-pcrest)*gap*dgap/((gi*gi-1.)**2.5)
        hbppi2 = sqcttf*sin(phit1-pcrest)*gap*gap*gap*gi/((gi*gi-1.)**3.5)
        hbppi3 = sqcttf*sin(phit1-pcrest)*gap*dgap/((gi*gi-1.)**2.5)
        hbppi4 = sqcttf*sin(phit1-pcrest)*gi*ddgap/((gi*gi-1.)**2.5)
        hbppi5 = sqcttf*sin(phit1-pcrest)*gi*gi*gap*dgap/((gi*gi-1.)**3.5)
        hbppi6 = sqcttf*sin(phit1-pcrest)*gi*gap**3/((gi*gi-1.)**3.5)
        hbppi7 = sqcttf*sin(phit1-pcrest)*gi*gi*dgap*gap/((gi*gi-1.)**3.5)
        hbppi8 = sqcttf*sin(phit1-pcrest)*gi*gi*gi*gap*gap*gap/((gi*gi-1.)**4.5)
        ! n=1
        hbppi = happi + t1(i)*xcc1*(-6.*hbppi1+15.*hbppi2-3.*hbppi3-3.*hbppi4+15.*hbppi5+30.*hbppi6+30.*hbppi7-105.* &
          hbppi8)
      end do
200   continue
      ! INTEGRALS to be multiplied by cos
      yh1p1 = yh1p1/2.*eqvl
      hapi = hapi/2.*eqvl
      happi = happi/2.*eqvl
      ! INTEGRALS to be multiplied by sin
      yh2p1 = yh2p1/2.*eqvl
      hbpi = hbpi/2.*eqvl
      hbppi = hbppi/2.*eqvl
      return
    end subroutine xtyplp1
    ! *******************************************************************
    ! SUBROUTINE xtylpk(GAMI,SAPHI,QSC,DCG)
    ! called by RESTAY and ETGAP
    ! INTEGRALS of HA0(Z) and HB0(Z)
    ! INTEGRALS of the second derivative of HA0(Z) and HB0(Z)
    ! zb = z+ASDL
    ! *******************************************************************
    subroutine xtylpk(gami, saphi, qsc, dcg)
      implicit real *8(a-h, o-z)
      common /consta/vl, pi, xmat, rpel, qst
      common /ttfc/tk, t1k, t2k, sk, s1k, s2k, fh
      common /bedycp/phslip, eqvl, asdl, peqvl, pavph, xkp1, xkp2, aa, bb, cc, dd, ee, pcrest, sqcttf
      common /typlpk/yh10pk, yh11pk, yh20pk, yh21pk
      common /gaus17/h1(17), t1(17)

      fh0 = fh/vl
      cgi = qsc/xmat
      gam2 = gami**2
      beti = sqrt(1.-1./gam2)
      xk1 = fh0/beti
      dtilk = eqvl
      ! CIRCULAIRES EN COS
      yh10pk = 0.
      yh11pk = 0.
      ! CIRCULAIRES EN SIN
      yh20pk = 0.
      yh21pk = 0.
      tilta2 = phslip/(2.*eqvl)
      if (phslip/=0.) desy = phslip/sin(phslip/2.)
      if (phslip==0.) desy = 2.
      cgam10 = ((gami*gami-1.)**1.5)/fh0
      phcrtk = (t1k*sk-s1k*tk)/(tk*tk+sk*sk)
      do i = 1, 17
        xcc = eqvl*(1.+h1(i))/2.
        xcc1 = xcc + asdl
        if (xcc1>dcg) go to 200
        phit0 = saphi - phslip*(eqvl-xcc)/(2.*eqvl) + pavph
        ! FONCTION GAMMA (Z)
        if (phslip/=0.) then
          git = cgi*sqcttf*cos(phit0-pcrest)/phslip
          gis = sin(xcc*tilta2)
        else
          git = cgi*sqcttf*cos(phit0-pcrest)
          gis = xcc/(2.*eqvl)
        end if
        gi = gami + git*gis
        bi = sqrt(1.-1./(gi*gi))
        ! Derivative of G0(Z) in relation with: PH01
        if (phslip/=0.) then
          gap = -cgi*sqcttf*sin(phit0-pcrest)*gis/phslip
        else
          gap = sin(phit0-pcrest)*gis
          gap = -cgi*sqcttf*gap
        end if
        ! Derivative of G0(Z) in relation with the equivalent K
        phit0k = -dtilk*(1.-xcc/eqvl)/2.
        if (phslip/=0.) then
          gic = cos(xcc*tilta2)
          gak1 = dtilk*cos(phit0-pcrest)*gis/(phslip*phslip)
          gak2 = sin(phit0-pcrest)*gis*(phit0k-phcrtk)/phslip
          gak3 = dtilk*cos(phit0-pcrest)*xcc*gic/(2.*phslip*eqvl)
          gak = cgi*sqcttf*(-gak1-gak2+gak3)
        else
          gak1 = sin(phit0-pcrest)*gis*(phit0k-phcrtk)
          gak = -cgi*sqcttf*gak1
        end if
        ! derivative of G0(Z) in relation with the equivalent k and the phase PHI
        if (phslip/=0.) then
          gic = cos(xcc*tilta2)
          gakp1 = dtilk*sin(phit0-pcrest)*gis/(phslip*phslip)
          gakp2 = cos(phit0-pcrest)*gis*(phit0k-phcrtk)/phslip
          gakp3 = dtilk*sin(phit0-pcrest)*xcc*gic/(2.*phslip*eqvl)
          gakp = cgi*sqcttf*(gakp1-gakp2-gakp3)
        else
          gakp1 = cos(phit0-pcrest)*gis*(phit0k-phcrtk)
          gakp = -cgi*sqcttf*gakp1
        end if
        ! INTEGRALS of HA0(Z) and HB0(Z)
        xint = 1./(bi*bi*bi*gi*gi*gi)
        phit1 = phit0 + xcc*phslip/(2.*eqvl)
        ! INTEGRALES DERIVE HA0(Z) HB0(Z)  k0 ET PHI
        dha01 = sqcttf*cos(phit1-pcrest)*gap/((gi*gi-1.)**2.5)
        dha02 = sqcttf*cos(phit1-pcrest)*gi*gi*gap/((gi*gi-1.)**3.5)
        dhb01 = sqcttf*sin(phit1-pcrest)*gap/((gi*gi-1.)**2.5)
        dhb02 = sqcttf*sin(phit1-pcrest)*gi*gi*gap/((gi*gi-1.)**3.5)
        ! n=1
        yh10pk = yh10pk + t1(i)*xcc1*cgam10*(3.*dha01-15.*dha02)
        yh20pk = yh20pk + t1(i)*xcc1*cgam10*(3.*dhb01-15.*dhb02)
        ! Integrals of HA(Z) (multiplied by (ph1i-ph10)*(kmi-km0)
        hapi1 = sqcttf*cos(phit1-pcrest)*gap*gak/((gi*gi-1.)**2.5)
        hapi2 = sqcttf*cos(phit1-pcrest)*gi*gakp/((gi*gi-1.)**2.5)
        hapi3 = sqcttf*cos(phit1-pcrest)*gi*gi*gap*gak/((gi*gi-1.)**3.5)
        ! n=1
        yh11pk = yh11pk + t1(i)*xcc1*(-3.*hapi1-3.*hapi2+15.*hapi3)
        ! Integrals of HB(Z) (multiplied by (ph1i-ph10)*(kmi-km0)
        hbpi1 = sqcttf*sin(phit1-pcrest)*gap*gak/((gi*gi-1.)**2.5)
        hbpi2 = sqcttf*sin(phit1-pcrest)*gi*gakp/((gi*gi-1.)**2.5)
        hbpi3 = sqcttf*sin(phit1-pcrest)*gi*gi*gap*gak/((gi*gi-1.)**3.5)
        ! n=1
        yh21pk = yh21pk + t1(i)*xcc1*(-3.*hbpi1-3.*hbpi2+15.*hbpi3)
      end do
200   continue
      ! Cosinus integrals
      yh10pk = yh10pk/2.*eqvl
      yh11pk = yh11pk/2.*eqvl
      ! Sinus integrals
      yh20pk = yh20pk/2.*eqvl
      yh21pk = yh21pk/2.*eqvl
      return
    end subroutine xtylpk
    ! *******************************************************************
    ! SUBROUTINE xtypj(GAMI,SAPHI,QSC,DCG)
    ! called by RESTAY and ETGAP
    ! INTEGRALS of g(G)*Ez(**2) *z**n   n=0,1,2
    ! *******************************************************************
    subroutine xtypj(gami, saphi, qsc, dcg)
      implicit real *8(a-h, o-z)
      common /consta/vl, pi, xmat, rpel, qst
      common /ttfc/tk, t1k, t2k, sk, s1k, s2k, fh
      common /bedycp/phslip, eqvl, asdl, peqvl, pavph, xkp1, xkp2, aa, bb, cc, dd, ee, pcrest, sqcttf
      common /typj/yfsk0, yfsk1, yfsk2, yfsp0, yfsp1, yfsp2, yfskc0, yfskc1, yfskc2, yfsck0, yfsck1, yfsck2, yfscp0, &
        yfscp1, yfscp2, yfs0, yfs1, yfs2
      common /gaus17/h1(17), t1(17)

      fh0 = fh/vl
      cgi = qsc/xmat
      gam2 = gami**2
      beti = sqrt(1.-1./gam2)
      xk1 = fh0/beti
      dtilk = eqvl
      yfs0 = 0.
      yfs1 = 0.
      yfs2 = 0.
      yfskc0 = 0.
      yfskc1 = 0.
      yfskc2 = 0.
      yfsk0 = 0.
      yfsk1 = 0.
      yfsk2 = 0.
      yfsck0 = 0.
      yfsck1 = 0.
      yfsck2 = 0.
      yfscp0 = 0.
      yfscp1 = 0.
      yfscp2 = 0.
      yfsp0 = 0.
      yfsp1 = 0.
      yfsp2 = 0.
      tilta2 = phslip/(2.*eqvl)
      if (phslip/=0.) desy = phslip/sin(phslip/2.)
      if (phslip==0.) desy = 2.
      cgam10 = ((gami*gami-1.)**1.5)/fh0
      phcrtk = (t1k*sk-s1k*tk)/(tk*tk+sk*sk)
      do i = 1, 17
        xcc = eqvl*(1.+h1(i))/2.
        xcc1 = xcc + asdl
        if (xcc1>dcg) go to 200
        phit0 = saphi - phslip*(eqvl-xcc)/(2.*eqvl) + pavph
        ! Function GAMMA (Z)
        if (phslip/=0.) then
          git = cgi*sqcttf*cos(phit0-pcrest)/phslip
          gis = sin(xcc*tilta2)
        else
          git = cgi*sqcttf*cos(phit0-pcrest)
          gis = xcc/(2.*eqvl)
        end if
        gi = gami + git*gis
        bi = sqrt(1.-1./(gi*gi))
        ! Derivative of G0(Z) with regard to the average k
        phit0k = -dtilk*(1.-xcc/eqvl)/2.
        if (phslip/=0.) then
          gic = cos(xcc*tilta2)
          gak1 = dtilk*cos(phit0-pcrest)*gis/(phslip*phslip)
          gak2 = sin(phit0-pcrest)*gis*(phit0k-phcrtk)/phslip
          gak3 = dtilk*cos(phit0-pcrest)*xcc*gic/(2.*phslip*eqvl)
          gak = cgi*sqcttf*(-gak1-gak2+gak3)
        else
          gak1 = sin(phit0-pcrest)*gis*(phit0k-phcrtk)
          gak = -cgi*sqcttf*gak1
        end if
        phit1 = phit0 + xcc*phslip/(2.*eqvl)
        phtz0 = (xcc/eqvl-.5)*dtilk
        xint = (gi*gi+2.)/((gi*gi-1.)**2)
        xfk1 = 2.*gi*(1.-2.*(gi*gi+2.)/(gi*gi-1.))/((gi*gi-1.)**2)
        ha0 = cos(phit1-pcrest)
        hb0 = sin(phit1-pcrest)
        ! n=0
        yfs0 = yfs0 + t1(i)*ha0*ha0*xint
        yfskc0 = yfskc0 - t1(i)*ha0*ha0*xfk1*cgam10
        yfsk0 = yfsk0 + t1(i)*ha0*ha0*xfk1*gak
        yfsck0 = yfsck0 - 2.*t1(i)*ha0*hb0*xint*(phtz0-phcrtk)
        ! n=1
        yfs1 = yfs1 + t1(i)*ha0*ha0*xint*xcc
        yfskc1 = yfskc1 - t1(i)*ha0*ha0*xfk1*cgam10*xcc
        yfsk1 = yfsk1 + t1(i)*ha0*ha0*xfk1*gak*xcc
        yfsck1 = yfsck1 - 2.*t1(i)*ha0*hb0*xint*(phtz0-phcrtk)*xcc
        ! n=2
        yfs2 = yfs2 + t1(i)*ha0*ha0*xint*xcc*xcc
        yfskc2 = yfskc2 - t1(i)*ha0*ha0*xfk1*cgam10*xcc*xcc
        yfsk2 = yfsk2 + t1(i)*ha0*ha0*xfk1*gak*xcc*xcc
        yfsck2 = yfsck2 - 2.*t1(i)*ha0*hb0*xint*(phtz0-phcrtk)*xcc*xcc
        ! Derivative of G0(Z) with regard to PH01
        if (phslip/=0.) then
          gap = -cgi*sqcttf*sin(phit0-pcrest)*gis/phslip
        else
          gap = sin(phit0-pcrest)*gis
          gap = -cgi*sqcttf*gap
        end if
        ! n=0
        yfsp0 = yfsp0 + t1(i)*xfk1*gap*ha0*ha0
        yfscp0 = yfscp0 - 2.*t1(i)*xint*ha0*hb0
        ! n=1
        yfsp1 = yfsp1 + t1(i)*xfk1*gap*ha0*ha0*xcc
        yfscp1 = yfscp1 - 2.*t1(i)*xint*ha0*hb0*xcc
        ! n=2
        yfsp2 = yfsp2 + t1(i)*xfk1*gap*ha0*ha0*xcc*xcc
        yfscp2 = yfscp2 - 2.*t1(i)*xint*ha0*hb0*xcc*xcc
      end do
200   continue
      ! IST=IAST
      yfs0 = yfs0/2.*eqvl
      yfs1 = yfs1/2.*eqvl
      yfs2 = yfs2/2.*eqvl
      yfskc0 = yfskc0/2.*eqvl
      yfskc1 = yfskc1/2.*eqvl
      yfskc2 = yfskc2/2.*eqvl
      yfsk0 = yfsk0/2.*eqvl
      yfsk1 = yfsk1/2.*eqvl
      yfsk2 = yfsk2/2.*eqvl
      yfsck0 = yfsck0/2.*eqvl
      yfsck1 = yfsck1/2.*eqvl
      yfsck2 = yfsck2/2.*eqvl
      yfscp0 = yfscp0/2.*eqvl
      yfscp1 = yfscp1/2.*eqvl
      yfscp2 = yfscp2/2.*eqvl
      yfsp0 = yfsp0/2.*eqvl
      yfsp1 = yfsp1/2.*eqvl
      yfsp2 = yfsp2/2.*eqvl
      return
    end subroutine xtypj
    ! *******************************************************************
    ! SUBROUTINE xtypm(GAMI,SAPHI,QSC,DCG)
    ! called by RESTAY and ETGAP
    ! INTEGRALS of g(G)*z**n  with n=0,1,2
    ! *******************************************************************
    subroutine xtypm(gami, saphi, qsc, dcg)
      implicit real *8(a-h, o-z)
      common /consta/vl, pi, xmat, rpel, qst
      common /ttfc/tk, t1k, t2k, sk, s1k, s2k, fh
      common /bedycp/phslip, eqvl, asdl, peqvl, pavph, xkp1, xkp2, aa, bb, cc, dd, ee, pcrest, sqcttf
      common /typm/ynsk0, ynsk1, ynsk2, ynsp0, ynsp1, ynsp2, ynsk0c, ynsk1c, ynsk2c, yns0, yns1, yns2
      common /gaus17/h1(17), t1(17)

      fh0 = fh/vl
      cgi = qsc/xmat
      dtilk = eqvl
      yns0 = 0.
      yns1 = 0.
      yns2 = 0.
      ynsk0c = 0.
      ynsk1c = 0.
      ynsk2c = 0.
      ynsk0 = 0.
      ynsk1 = 0.
      ynsk2 = 0.
      ynsp0 = 0.
      ynsp1 = 0.
      ynsp2 = 0.
      gam2 = gami**2
      beti = sqrt(1.-1./gam2)
      xk1 = fh0/beti
      tilta2 = phslip/(2.*eqvl)
      if (phslip/=0.) desy = phslip/sin(phslip/2.)
      if (phslip==0.) desy = 2.
      cgam10 = ((gami*gami-1.)**1.5)/fh0
      phcrtk = (t1k*sk-s1k*tk)/(tk*tk+sk*sk)
      do i = 1, 17
        xcc = eqvl*(1.+h1(i))/2.
        xcc1 = xcc + asdl
        if (xcc1>dcg) go to 200
        phit0 = saphi - phslip*(eqvl-xcc)/(2.*eqvl) + pavph
        ! Function GAMMA (Z)
        if (phslip/=0.) then
          git = cgi*sqcttf*cos(phit0-pcrest)/phslip
          gis = sin(xcc*tilta2)
        else
          git = cgi*sqcttf*cos(phit0-pcrest)
          gis = xcc/(2.*eqvl)
        end if
        gi = gami + git*gis
        bi = sqrt(1.-1./(gi*gi))
        ! Derivative of G0(Z) with regard to the average k
        phit0k = -dtilk*(1.-xcc/eqvl)/2.
        if (phslip/=0.) then
          gic = cos(xcc*tilta2)
          gak1 = dtilk*cos(phit0-pcrest)*gis/(phslip*phslip)
          gak2 = sin(phit0-pcrest)*gis*(phit0k-phcrtk)/phslip
          gak3 = dtilk*cos(phit0-pcrest)*xcc*gic/(2.*phslip*eqvl)
          gak = cgi*sqcttf*(-gak1-gak2+gak3)
        else
          gak1 = sin(phit0-pcrest)*gis*(phit0k-phcrtk)
          gak = -cgi*sqcttf*gak1
        end if
        xint = (gi*gi+2.)/((gi*gi-1.)**2)
        xnk1 = 2.*gi*(1.-2.*(gi*gi+2.)/(gi*gi-1.))/((gi*gi-1.)**2)
        ! n=0
        yns0 = yns0 + t1(i)*xint
        ynsk0c = ynsk0c - t1(i)*xnk1*cgam10
        ynsk0 = ynsk0 + t1(i)*xnk1*gak
        ! n=1
        yns1 = yns1 + t1(i)*xint*xcc
        ynsk1c = ynsk1c - t1(i)*xnk1*cgam10*xcc
        ynsk1 = ynsk1 + t1(i)*xnk1*gak*xcc
        ! n=2
        yns2 = yns2 + t1(i)*xint*xcc*xcc
        ynsk2c = ynsk2c - t1(i)*xnk1*cgam10*xcc*xcc
        ynsk2 = ynsk2 + t1(i)*xnk1*gak*xcc*xcc
        ! DERIVE G0(Z) RELATIF A PH01
        if (phslip/=0.) then
          gap = -cgi*sqcttf*sin(phit0-pcrest)*gis/phslip
        else
          gap = sin(phit0-pcrest)*gis
          gap = -cgi*sqcttf*gap
        end if
        ynsp0 = ynsp0 + t1(i)*xnk1*gap
        ynsp1 = ynsp1 + t1(i)*xnk1*gap*xcc
        ynsp2 = ynsp2 + t1(i)*xnk1*gap*xcc*xcc
      end do
200   continue
      yns0 = yns0/2.*eqvl
      yns1 = yns1/2.*eqvl
      yns2 = yns2/2.*eqvl
      ynsk0c = ynsk0c/2.*eqvl
      ynsk1c = ynsk1c/2.*eqvl
      ynsk2c = ynsk2c/2.*eqvl
      ynsk0 = ynsk0/2.*eqvl
      ynsk1 = ynsk1/2.*eqvl
      ynsk2 = ynsk2/2.*eqvl
      ynsp0 = ynsp0/2.*eqvl
      ynsp1 = ynsp1/2.*eqvl
      ynsp2 = ynsp2/2.*eqvl
      return
    end subroutine xtypm
    ! *******************************************************************
    ! FUNCTION gamci(PHI,PCRESI,GAMI,IST,QSC)
    ! called by RESTAY and ETGAP
    ! CURRENT GAMMA VALUE (the POSITION IS GIVEN BY IST)
    ! *******************************************************************
    function gamci(phi, pcresi, gami, ist, qsc)
      implicit real *8(a-h, o-z)
      common /consta/vl, pi, xmat, rpel, qst
      common /ttfc/tk, t1k, t2k, sk, s1k, s2k, fh
      common /bedycp/phslip, eqvl, asdl, peqvl, pavph, xkp1, xkp2, aa, bb, cc, dd, ee, pcrest, sqcttf
      common /gaus17/h1(17), t1(17)

      gamci = 0.
      if (ist>17) return
      cgi = qsc/xmat
      tilta2 = phslip/(2.*eqvl)
      i = ist
      xcc = eqvl*(1.+h1(i))/2.
      phit0 = phi - phslip*(eqvl-xcc)/(2.*eqvl)
      ! Function GAMMA (Z)
      if (phslip/=0.) then
        git = cgi*sqcttf*cos(phit0-pcresi)/phslip
        gis = sin(xcc*tilta2)
      else
        git = cgi*sqcttf*cos(phit0-pcrest)
        gis = xcc/(2.*eqvl)
      end if
      gamci = gami + git*gis
      return
    end function gamci
    ! *******************************************************************
    ! SUBROUTINE intga(npt,ireca)
    ! Calculate the beam self fields acting on each particle (called by
    ! SCHERM) Gauss quadrature
    ! *******************************************************************
    subroutine intga(npt, ireca)
      implicit real *8(a-h, o-z)
      parameter(iptsz=100002, maxcell=3000, maxcell1=3000)
      common /consta/vl, pi, xmat, rpel, qst
      common /ttfc/tk, t1k, t2k, sk, s1k, s2k, fh
      common /hermt/afxt(22), afyt(22), afzt(22)
      common /hermd/afxm(20), afym(20), afzm(20)
      common /hermr/afxr(20), afyr(20), afzr(20)
      common /hermrr/afxrr(20), afyrr(20), afzrr(20)
      common /sizr/xrms3, yrms3, zrms3, zcgr3
      common /degherm/nmaz, nmazr, nmaxy
      common /sizt/xrms, yrms, zrms
      common /sizp/xrms1, yrms1, zrms1, xrms2, yrms2, zrms2, imaxd
      common /elcg/xcgd, ycgd, zcgd, xcgr, ycgr, zcgr
      common /faisc/f(10, iptsz), imax, ngood
      common /intgrt/ex, ey, ez
      common /sc3/beamc, scdist, sce10, cplm, ect, apl, ichaes, iscsp
      common /part/xc(iptsz), yc(iptsz), zc(iptsz)
      common /twcst/epsilon
      common /ecor/const
      common /npart/imaxr
      common /macro/ratei
      logical ichaes
      dimension ui(6), wi(6)
      data (ui(j), j=1, 6)/.033765, .169395, .380690, .619310, .830605, .966234/
      data (wi(j), j=1, 6)/.085662, .180381, .233957, .233957, .180381, .085662/

      ! Initialize some constants and variables
      ! freq. in MHz
      freq = fh*0.5e-06/pi
      ! qmpart=coul , xrms=meters
      ! ireca=0 : first ellipsoid  over nmaxy terms
      ! ireca=4 : one ellipsoid over the first term
      xrmsc = 0.
      yrmsc = 0.
      zrmsc = 0.
      xgc = 0.
      ygc = 0.
      zgc = 0.
      if (ireca==0 .or. ireca==4) then
        xrmsc = xrms1
        yrmsc = yrms1
        zrmsc = zrms1
        xgc = xcgd
        ygc = ycgd
        zgc = zcgd
      end if
      ! ireca=1 : second ellipsoid
      if (ireca==1) then
        xrmsc = xrms2
        yrmsc = yrms2
        zrmsc = zrms2
        xgc = xcgr
        ygc = ycgr
        zgc = zcgr
      end if
      ! ireca=2 : third elllipsoid
      if (ireca==2) then
        xrmsc = xrms3
        yrmsc = yrms3
        zrmsc = zrms3
        xgc = 0.
        ygc = 0.
        zgc = zcgr3
      end if
      qmpart = 1.0e-09*beamc/(float(imax)*freq)
      ! omment        const=qmpart*xrmsc*yrmsc*zrmsc/(2.*epsilon)
      qmpart = qmpart*ratei
      const = qmpart/(2.*epsilon)
      dnorm = (xrmsc*yrmsc*zrmsc)**.333333333
      dsq = dnorm*dnorm
      xsq = (xc(npt)-xgc)*(xc(npt)-xgc)
      ysq = (yc(npt)-ygc)*(yc(npt)-ygc)
      zsq = (zc(npt)-zgc)*(zc(npt)-zgc)
      if (ireca==0) zc1 = zc(npt) - zgc
      if (ireca==1) zc2 = zc(npt) - zgc
      ex = 0.
      if (ireca==2) zc2 = zc(npt) - zgc
      ey = 0.
      ez = 0.
      ! initialize integrals to 0.
      ! integrate all 3 components (x,y,z)
      do j = 1, 6
        a1 = xrmsc*xrmsc - dsq + dsq/ui(j)
        a2 = yrmsc*yrmsc - dsq + dsq/ui(j)
        a3 = zrmsc*zrmsc - dsq + dsq/ui(j)
        t1 = xsq/a1
        t2 = ysq/a2
        t3 = zsq/a3
        txyz = sqrt(t1+t2+t3)
        ff1 = drxyz(nmaxy, txyz, ireca)/(ui(j)*ui(j)*sqrt(a1*a2*a3))
        fxn = ff1/a1
        fyn = ff1/a2
        fzn = ff1/a3
        ex = ex + wi(j)*fxn*dsq
        ey = ey + wi(j)*fyn*dsq
        ez = ez + wi(j)*fzn*dsq
      end do
      ! Field components are in Newton/Coulomb
      ex = ex*const*xc(npt)
      ey = ey*const*yc(npt)
      ez = ez*const*(zc(npt)-zgc)
      return
    end subroutine intga
    ! *******************************************************************
    ! SUBROUTINE sizcor(ect,xrms,yrms,zrms,imaxd)
    ! Computes the R.M.S. of the bunch at positions of space charge
    ! computation
    ! *******************************************************************
    subroutine sizcor(ect, xrms, yrms, zrms, imaxd)
      implicit real *8(a-h, o-z)
      parameter(iptsz=100002, maxcell=3000, maxcell1=3000)
      common /part/xc(iptsz), yc(iptsz), zc(iptsz)
      common /cgrms/xsum, ysum, zsum
      common /faisc/f(10, iptsz), imax, ngood

      imaxf = 0
      imaxx = ngood
      xsum = 0.
      ysum = 0.
      zsum = 0.
      xrmsp = xrms
      yrmsp = yrms
      zrmsp = zrms
      xsqsum = 0.
      ysqsum = 0.
      zsqsum = 0.
      if (imaxd>0) imaxx = imaxd
      do i = 1, imaxx
        xcoup = abs(xc(i)/xrmsp)
        ycoup = abs(yc(i)/yrmsp)
        zcoup = abs(zc(i)/zrmsp)
        if (xcoup<=ect .and. ycoup<=ect .and. zcoup<=ect) then
          xsum = xsum + xc(i)
          ysum = ysum + yc(i)
          zsum = zsum + zc(i)
          xsqsum = xsqsum + xc(i)*xc(i)
          ysqsum = ysqsum + yc(i)*yc(i)
          zsqsum = zsqsum + zc(i)*zc(i)
          imaxf = imaxf + 1
        end if
      end do
      xsum = xsum/imaxf
      ysum = ysum/imaxf
      zsum = zsum/imaxf
      xsqsum = xsqsum/imaxf
      ysqsum = ysqsum/imaxf
      zsqsum = zsqsum/imaxf
      xrms = sqrt(xsqsum-xsum*xsum)
      yrms = sqrt(ysqsum-ysum*ysum)
      zrms = sqrt(zsqsum-zsum*zsum)
      return
    end subroutine sizcor
    ! *******************************************************************
    ! SUBROUTINE sizrms(imaxd,xrms,yrms,zrms,zmin)
    ! partial R.M.S. (called by SCHERM)
    ! *******************************************************************
    subroutine sizrms(imaxd, xrms, yrms, zrms, zmin)
      implicit real *8(a-h, o-z)
      parameter(iptsz=100002, maxcell=3000, maxcell1=3000)
      common /part/xc(iptsz), yc(iptsz), zc(iptsz)
      common /cgrms/xsum, ysum, zsum
      common /faisc/f(10, iptsz), imax, ngood

      imaxx = ngood
      xsum = 0.
      ysum = 0.
      zsum = 0.
      if (imaxd>0) then
        do i = 1, imaxd
          zc(i) = zc(i) - zmin
        end do
        imaxx = imaxd
      end if
      xsqsum = 0.
      ysqsum = 0.
      zsqsum = 0.
      do i = 1, imaxx
        xsum = xsum + xc(i)
        ysum = ysum + yc(i)
        zsum = zsum + zc(i)
        xsqsum = xsqsum + xc(i)*xc(i)
        ysqsum = ysqsum + yc(i)*yc(i)
        zsqsum = zsqsum + zc(i)*zc(i)
      end do
      xsum = xsum/imaxx
      ysum = ysum/imaxx
      zsum = zsum/imaxx
      xsqsum = xsqsum/float(imaxx)
      ysqsum = ysqsum/float(imaxx)
      zsqsum = zsqsum/float(imaxx)
      xrms = sqrt(xsqsum-xsum*xsum)
      yrms = sqrt(ysqsum-ysum*ysum)
      zrms = sqrt(zsqsum-zsum*zsum)
      return
    end subroutine sizrms
    ! *******************************************************************
    ! FUNCTION snzt(CC,DD)
    ! specific function called by SCHERM
    ! *******************************************************************
    function snzt(cc, dd)
      implicit real *8(a-h, o-z)
      common /degherm/nmaz, nmazr, nmaxy
      common /sizt/xrms, yrms, zrms
      common /sizp/xrms1, yrms1, zrms1, xrms2, yrms2, zrms2, imaxd
      common /gaus17/h1(17), t1(17)

      snzt = 0.
      do i = 1, 17
        z = (cc+dd)/2. + (dd-cc)*h1(i)/2.
        denz = densz(nmaz, z, 0)
        if (denz<0.) denz = 0.
        snzt = snzt + t1(i)*denz
      end do
      snzt = snzt*(dd-cc)/2.
      return
    end function snzt
    ! *******************************************************************
    ! FUNCTION snzd(cc,dd)
    ! specific function called by SCHERM
    ! *******************************************************************
    function snzd(cc, dd)
      implicit real *8(a-h, o-z)
      common /degherm/nmaz, nmazr, nmaxy
      common /sizt/xrms, yrms, zrms
      common /sizp/xrms1, yrms1, zrms1, xrms2, yrms2, zrms2, imaxd
      common /gaus17/h1(17), t1(17)

      snzd = 0.
      do i = 1, 17
        z = (cc+dd)/2. + (dd-cc)*h1(i)/2.
        denz = densz(nmaz, z, 0)
        if (denz<0.) go to 13
        zz = (z-cc)
        snzd = snzd + t1(i)*denz
      end do
13    continue
      snzd = snzd*(dd-cc)
      return
    end function snzd
    ! *******************************************************************
    ! FUNCTION vaprz(CC,DD)
    ! specific function called by SCHERM
    ! *******************************************************************
    function vaprz(cc, dd)
      implicit real *8(a-h, o-z)
      common /degherm/nmaz, nmazr, nmaxy
      common /sizt/xrms, yrms, zrms
      common /sizp/xrms1, yrms1, zrms1, xrms2, yrms2, zrms2, imaxd
      common /gaus17/h1(17), t1(17)

      vaprz = 0.
      var1 = 0.
      var2 = 0.
      do i = 1, 17
        z = (cc+dd)/2. + (dd-cc)*h1(i)/2.
        denz = densz(nmaz, z, 0)
        if (denz<0.) go to 13
        zz = (z-cc)
        var1 = var1 + t1(i)*zz*zz*denz
        var2 = var2 + t1(i)*denz
      end do
13    continue
      vaprz = var1/var2
      return
    end function vaprz
    ! *******************************************************************
    ! FUNCTION prinz(CC,DD,KAP,ZRMSS1)
    ! specific function called by SCHERM
    ! *******************************************************************
    function prinz(cc, dd, kap, zrmss1)
      implicit real *8(a-h, o-z)
      common /degherm/nmaz, nmazr, nmaxy
      common /sizt/xrms, yrms, zrms
      common /sizp/xrms1, yrms1, zrms1, xrms2, yrms2, zrms2, imaxd
      common /gaus17/h1(17), t1(17)

      prinz = 0.
      k = kap - 1
      do i = 1, 17
        denz = 0.
        z = (cc+dd)/2. + (dd-cc)*h1(i)/2.
        denz = densz(nmaz, z, 0)
        if (denz<0.) go to 13
        zz = (z-cc)/zrmss1
        prinz = prinz + t1(i)*herm(2*k, zz)*denz
      end do
13    continue
      prinz = prinz*(dd-cc)/2.
      return
    end function prinz
    ! *******************************************************************
    ! SUBROUTINE rchsom(ZI,ZF,NMAZ)
    ! specific function called by SCHERM
    ! Look for the top of the partial distributions
    ! *******************************************************************
    subroutine rchsom(zi, zf, nmaz)
      implicit real *8(a-h, o-z)

      xpz = abs((zf-zi))/400.
1     continue
      ztest = abs(zf-zi)
      if (ztest<=xpz) return
      z1 = (zf+zi)/2.
      z2 = (z1+zi)/2.
      t1 = densz(nmaz, z1, 0)
      t2 = densz(nmaz, z2, 0)
      ! new interval: Z2,ZF
      if (t1>t2) zi = z2
      ! new interval  : ZI,Z1
      if (t1<t2) zf = z1
      go to 1
    end subroutine rchsom
    ! *******************************************************************
    ! SUBROUTINE rchsor(AA,BB,CC,DD,ZS)
    ! specific function called by SCHERM
    ! Look for the top of the partial distributions
    ! *******************************************************************
    subroutine rchsor(aa, bb, cc, dd, zs)
      implicit real *8(a-h, o-z)

      zi = aa
      zf = cc
      xpz = abs((zf-zi))/400.
1     continue
      ztest = abs(zf-zi)
      if (ztest<=xpz) then
        zs = (zi+zf)/2.
        return
      end if
      z1 = (zf+zi)/2.
      z2 = (z1+zi)/2.
      t1 = dendif(z1, aa, bb, cc, dd)
      t2 = dendif(z2, aa, bb, cc, dd)
      ! NEW INTERVAL : Z2,ZF
      if (t1>t2) zi = z2
      ! NEW INTERVAL : ZI,Z1
      if (t1<t2) zf = z1
      go to 1
    end subroutine rchsor
    ! *******************************************************************
    ! FUNCTION herm(M,X)
    ! Hermite polynomials
    ! *******************************************************************
    function herm(m, x)
      implicit real *8(a-h, o-z)
      dimension he(30)

      if (m==0) then
        herm = 1.
        return
      end if
      if (m==1) then
        herm = x
        return
      end if
      he(1) = 1.
      he(2) = x
      m1 = m - 1
      do k = 1, m1
        he(k+2) = x*he(k+1) - float(k)*he(k)
      end do
      herm = he(m+1)
      return
    end function herm
    ! *******************************************************************
    ! FUNCTION densz(M,Z,IRECA)
    ! called by SCHERM
    ! Look for the distribution in z position
    ! *******************************************************************
    function densz(m, z, ireca)
      implicit real *8(a-h, o-z)
      common /hermt/afxt(22), afyt(22), afzt(22)
      common /hermd/afxm(20), afym(20), afzm(20)
      common /hermr/afxr(20), afyr(20), afzr(20)

      densz = 0.
      do k = 1, m
        kap = k - 1
        if (ireca==0) densz = densz + exp(-z*z/2.)*afzt(k)*herm(kap, z)
        if (ireca==2) densz = densz + exp(-z*z/2.)*afzm(k)*herm(2*kap, z)
        if (ireca==3) densz = densz + exp(-z*z/2.)*afzr(k)*herm(2*kap, z)
      end do
      return
    end function densz
    ! *******************************************************************
    ! FUNCTION codsy(BB,CC,DD,EE,KAP)
    ! specific function called by SCHERM
    ! *******************************************************************
    function codsy(bb, cc, dd, ee, kap)
      implicit real *8(a-h, o-z)
      common /degherm/nmaz, nmazr, nmaxy
      common /sizt/xrms, yrms, zrms
      common /sizp/xrms1, yrms1, zrms1, xrms2, yrms2, zrms2, imaxd
      common /gaus13/h(13), t(13)

      codsy = 0.
      k = kap - 1
      ff = 2.*ee - cc
      do i = 1, 13
        dendifr = 0.
        z = (cc+ff)/2. + (cc-ff)*t(i)/2.
        if (z>=ff .and. z<ee) then
          zs = 2.*ee - z
          z1 = dd + bb - zs
          if (zs<bb) dendifr = densz(nmaz, zs, 0)
          if (zs>=bb) dendifr = densz(nmaz, zs, 0) - densz(nmaz, z1, 0)
        end if
        if (z>=ee) then
          if (z<bb) dendifr = densz(nmaz, z, 0)
          z1 = dd + bb - z
          if (z>=bb) dendifr = densz(nmaz, z, 0) - densz(nmaz, z1, 0)
        end if
        if (dendifr<0.) dendifr = 0.
        zz = z - ee
        ! ZRMS2(EFFECTIF)=ZRMS2(CALCULE)*ZRMS
        zz = zz/zrms2
        codsy = codsy + h(i)*herm(2*k, zz)*dendifr
      end do
      codsy = codsy*(cc-ff)/2.
      return
    end function codsy
    ! *******************************************************************
    ! FUNCTION codif(BB,CC,DD,EE,EE1,KAP)
    ! specific function called by SCHERM
    ! *******************************************************************
    function codif(bb, cc, dd, ee, ee1, kap)
      implicit real *8(a-h, o-z)
      common /degherm/nmaz, nmazr, nmaxy
      common /sizt/xrms, yrms, zrms
      common /sizp/xrms1, yrms1, zrms1, xrms2, yrms2, zrms2, imaxd
      common /sizr/xrms3, yrms3, zrms3, zcgr3
      common /gaus13/h(13), t(13)

      codif = 0.
      k = kap - 1
      ff = 2.*ee1 - ee
      ff1 = 2.*ee - cc
      dendifr = 0.
      do i = 1, 13
        z = (ee+ff)/2. + (ee-ff)*t(i)/2.
        if (z<=ff1) dendifr = densz(nmaz, z, 0)
        if (z>=ff1) then
          zs = 2.*ee - z
          z1 = dd + bb - zs
          if (zs<bb) dendifr = densz(nmaz, zs, 0)
          if (zs>=bb) dendifr = densz(nmaz, zs, 0) - densz(nmaz, z1, 0)
          dendifr = densz(nmaz, z, 0) - dendifr
        end if
        if (z>0.) dendifr = 0.
        if (dendifr<0.) dendifr = 0.
        zz = z - ee1
        ! ZRMS2(EFFECTIF)=ZRMS2(CALCULE)*ZRMS
        zz = zz/zrms3
        codif = codif + h(i)*herm(2*k, zz)*dendifr
      end do
      codif = -codif*ff/2.
      return
    end function codif
    ! *******************************************************************
    ! FUNCTION varia(BB,CC,DD,EE)
    ! specific function called by SCHERM
    ! *******************************************************************
    function varia(bb, cc, dd, ee)
      implicit real *8(a-h, o-z)
      common /degherm/nmaz, nmazr, nmaxy
      common /sizt/xrms, yrms, zrms
      common /sizp/xrms1, yrms1, zrms1, xrms2, yrms2, zrms2, imaxd
      common /gaus13/h(13), t(13)

      varia = 0.
      codi1 = 0.
      codi2 = 0.
      ff = 2.*ee - cc
      do i = 1, 13
        dendifr = 0.
        z = (cc+ff)/2. + (cc-ff)*t(i)/2.
        if (z>=ff .and. z<ee) then
          zs = 2.*ee - z
          z1 = dd + bb - zs
          if (zs<bb) dendifr = densz(nmaz, zs, 0)
          if (zs>=bb) dendifr = densz(nmaz, zs, 0) - densz(nmaz, z1, 0)
        end if
        if (z>=ee) then
          if (z<bb) dendifr = densz(nmaz, z, 0)
          z1 = dd + bb - z
          if (z>=bb) dendifr = densz(nmaz, z, 0) - densz(nmaz, z1, 0)
        end if
        zz = z - ee
        if (dendifr<0.) dendifr = 0.
        codi1 = codi1 + h(i)*zz*zz*dendifr
        codi2 = codi2 + h(i)*dendifr
      end do
      varia = codi1/codi2
      return
    end function varia
    ! *******************************************************************
    ! FUNCTION variz(BB,CC,DD,EE,EE1)
    ! specific function called by SCHERM
    ! *******************************************************************
    function variz(bb, cc, dd, ee, ee1)
      implicit real *8(a-h, o-z)
      common /degherm/nmaz, nmazr, nmaxy
      common /sizt/xrms, yrms, zrms
      common /sizp/xrms1, yrms1, zrms1, xrms2, yrms2, zrms2, imaxd
      common /gaus13/h(13), t(13)

      variz = 0.
      codi1 = 0.
      codi2 = 0.
      ff = 2.*ee1 - ee
      ff1 = 2.*ee - cc
      do i = 1, 13
        dendifr = 0.
        z = (ee+ff)/2. + (ee-ff)*t(i)/2.
        if (z<=ff1) dendifr = densz(nmaz, z, 0)
        if (z>=ff1) then
          zs = 2.*ee - z
          z1 = dd + bb - zs
          if (zs<bb) dendifr = densz(nmaz, zs, 0)
          if (zs>=bb) dendifr = densz(nmaz, zs, 0) - densz(nmaz, z1, 0)
          dendifr = densz(nmaz, z, 0) - dendifr
        end if
        if (z>ee) dendifr = 0.
        if (dendifr<0.) dendifr = 0.
        zz = z - ee1
        codi1 = codi1 + h(i)*zz*zz*dendifr
        codi2 = codi2 + h(i)*dendifr
      end do
      variz = codi1/codi2
      return
    end function variz
    ! *******************************************************************
    ! FUNCTION grz(AA,BB,CC,DD,EE)
    ! specific function called by SCHERM
    ! *******************************************************************
    function grz(aa, bb, cc, dd, ee)
      implicit real *8(a-h, o-z)
      common /degherm/nmaz, nmazr, nmaxy
      common /sizt/xrms, yrms, zrms
      common /sizp/xrms1, yrms1, zrms1, xrms2, yrms2, zrms2, imaxd
      common /gaus13/h(13), t(13)

      grz = 0.
      gz = 0.
      gs = 0.
      do i = 1, 13
        z = (ee+aa)/2. + (ee-aa)*t(i)/2.
        dif = dendir(z, aa, bb, cc, dd, ee)
        if (dif<0.) dif = 0.
        gz = gz + h(i)*z*dif
        gs = gs + h(i)*dif
      end do
      if (gs<=0.) grz = 0.
      if (gs>0.) grz = gz/gs
      return
    end function grz
    ! *******************************************************************
    ! FUNCTION dendir(Z,AA,BB,CC,DD,EE)
    ! Specific function called by SCHERM
    ! Calculate the value (nt(z)-nm(z))
    ! *******************************************************************
    function dendir(z, aa, bb, cc, dd, ee)
      implicit real *8(a-h, o-z)
      common /degherm/nmaz, nmazr, nmaxy

      dendir = 0.
      ff = 2.*ee - cc
      if (z<aa) dendir = 0.
      if (z>=aa .and. z<ff) dendir = densz(nmaz, z, 0)
      if (z>=ff .and. z<ee) then
        zs = 2.*ee - z
        z1 = dd + bb - zs
        dendifr = 0.
        if (zs<bb) dendifr = densz(nmaz, zs, 0)
        if (zs>=bb) dendifr = densz(nmaz, zs, 0) - densz(nmaz, z1, 0)
        dendir = densz(nmaz, z, 0) - dendifr
      end if
      if (z>=ee) dendir = 0.
      return
    end function dendir
    ! *******************************************************************
    ! FUNCTION dendif(Z,AA,BB,CC,DD)
    ! Specific function called by SCHERM
    ! Calculate the value (nt(z)-nm(z))
    ! *******************************************************************
    function dendif(z, aa, bb, cc, dd)
      implicit real *8(a-h, o-z)
      common /degherm/nmaz, nmazr, nmaxy

      dendif = 0.
      if (z<aa) dendif = 0.
      if (z>=aa .and. z<bb) dendif = densz(nmaz, z, 0)
      if (z>=bb .and. z<cc) then
        z1 = dd + bb - z
        dendif = densz(nmaz, z, 0) - densz(nmaz, z1, 0)
      end if
      if (z>=cc) dendif = 0.
      return
    end function dendif
    ! *******************************************************************
    ! FUNCTION denpd(XYZ,NMAXY,NMAZ)
    ! Specific function called by SCHERM
    ! Represents the distribution:(n(x)+n(y)+n(z))/3
    ! *******************************************************************
    function denpd(xyz, nmaxy, nmaz)
      implicit real *8(a-h, o-z)

      denpd = (densx(nmaxy,xyz,1)+densy(nmaxy,xyz,1)+densz(nmaz,xyz,2))/3.
      return
    end function denpd
    ! *******************************************************************
    ! FUNCTION drxyz(M,XYZ,IRECA)
    ! Specific function called by SCHERM
    ! Calculate the derivatives of:(n(x)+n(y)+n(z))/3
    ! IRECA=0 : for the first ellipse
    ! IRECA=1 : for the second ellipse
    ! IRECA=2 : for the third ellipse
    ! *******************************************************************
    function drxyz(m, xyz, ireca)
      implicit real *8(a-h, o-z)
      common /hermt/afxt(22), afyt(22), afzt(22)
      common /hermd/afxm(20), afym(20), afzm(20)
      common /hermr/afxr(20), afyr(20), afzr(20)
      common /sizp/xrms1, yrms1, zrms1, xrms2, yrms2, zrms2, imaxd
      common /hermrr/afxrr(20), afyrr(20), afzrr(20)
      common /sizr/xrms3, yrms3, zrms3, zcgr3
      common /consta/vl, pi, xmat, rpel, qst

      deriv1 = 0.
      deriv2 = 0.
      if (abs(xyz)>13.) xyz = 13.
      fe = exp(-xyz*xyz/2.)
      axyz = abs(xyz)
      msto = m
      do k = 2, m
        kap = k - 1
        kah = 2*kap - 1
        if (ireca==0) then
          dxxyz = fe*float(kap)*afxm(k)*hers(kah, axyz)
          dyxyz = fe*float(kap)*afym(k)*hers(kah, axyz)
          dzxyz = fe*float(kap)*afzm(k)*hers(kah, axyz)
          deriv1 = deriv1 + (dxxyz+dyxyz+dzxyz)
        end if
        if (ireca==1) then
          dxxyz = fe*float(kap)*afxr(k)*hers(kah, axyz)
          dyxyz = fe*float(kap)*afyr(k)*hers(kah, axyz)
          dzxyz = fe*float(kap)*afzr(k)*hers(kah, axyz)
          deriv1 = deriv1 + (dxxyz+dyxyz+dzxyz)
        end if
        if (ireca==2) then
          dxxyz = fe*float(kap)*afxrr(k)*hers(kah, axyz)
          dyxyz = fe*float(kap)*afyrr(k)*hers(kah, axyz)
          dzxyz = fe*float(kap)*afzrr(k)*hers(kah, axyz)
          deriv1 = deriv1 + (dxxyz+dyxyz+dzxyz)
        end if
      end do
      do k = 1, m
        kap = 2*(k-1)
        if (ireca==0) then
          dxxyz = -fe*afxm(k)*herm(kap, xyz)
          dyxyz = -fe*afym(k)*herm(kap, xyz)
          dzxyz = -fe*afzm(k)*herm(kap, xyz)
          deriv2 = deriv2 + .5*(dxxyz+dyxyz+dzxyz)
        end if
        if (ireca==1) then
          dxxyz = -fe*afxr(k)*herm(kap, xyz)
          dyxyz = -fe*afyr(k)*herm(kap, xyz)
          dzxyz = -fe*afzr(k)*herm(kap, xyz)
          deriv2 = deriv2 + .5*(dxxyz+dyxyz+dzxyz)
        end if
        if (ireca==2) then
          dxxyz = -fe*afxrr(k)*herm(kap, xyz)
          dyxyz = -fe*afyrr(k)*herm(kap, xyz)
          dzxyz = -fe*afzrr(k)*herm(kap, xyz)
          deriv2 = deriv2 + .5*(dxxyz+dyxyz+dzxyz)
        end if
      end do
      drxyz = -(deriv1+deriv2)/(3.*pi)
      m = msto
      return
    end function drxyz
    ! *******************************************************************
    ! FUNCTION hers(M,X)
    ! Specific Hermite polynomials called by the function DRXYZ
    ! *******************************************************************
    function hers(m, x)
      implicit real *8(a-h, o-z)
      dimension he(30)

      if (m==1) then
        hers = 1.
        return
      end if
      if (m==3) then
        hers = x*x - 3.
        return
      end if
      he(1) = 1.
      he(2) = x*x - 3.
      xm1 = float((m+1)/2) + .01
      m1 = int(xm1) - 2
      do k = 1, m1
        he(k+2) = herm(2*(k+2)-2, abs(x)) - float(2*(k+2)-2)*he(k+1)
      end do
      hers = he(m1+2)
      return
    end function hers
    ! *******************************************************************
    ! FUNCTION copdr(XI,XF,KAP)
    ! Specific function called by SCHERM
    ! Calculate the Hermite coefficients for :(n(x)+n(y)+n(z))/3.
    ! *******************************************************************
    function copdr(xi, xf, kap)
      implicit real *8(a-h, o-z)
      common /degherm/nmaz, nmazr, nmaxy
      common /gaus13/h(13), t(13)

      copdr = 0.
      k = kap - 1
      do i = 1, 13
        z = (xi+xf)/2. + (xf-xi)*t(i)/2.
        dend = denrs(z)
        copdr = copdr + h(i)*herm(2*k, z)*dend
      end do
      copdr = copdr*(xf-xi)/2.
      return
    end function copdr
    ! *******************************************************************
    ! FUNCTION densx(M,X,IRECA)
    ! Specific function called by SCHERM
    ! Calculate the distribution :(n(x)+n(y)+n(z))/3. at the x position
    ! *******************************************************************
    function densx(m, x, ireca)
      implicit real *8(a-h, o-z)
      common /hermt/afxt(22), afyt(22), afzt(22)
      common /hermd/afxm(20), afym(20), afzm(20)
      common /hermr/afxr(20), afyr(20), afzr(20)

      densx = 0.
      do k = 1, m
        kap = k - 1
        if (ireca==0) densx = densx + exp(-x*x/2.)*afxt(k)*herm(2*kap, abs(x))
        if (ireca==1) densx = densx + exp(-x*x/2.)*afxm(k)*herm(2*kap, abs(x))
      end do
      return
    end function densx
    ! *******************************************************************
    ! FUNCTION densy(M,Y,IRECA)
    ! Specific function called by SCHERM
    ! Calculate the distribution :(n(x)+n(y)+n(z))/3. at the y position
    ! *******************************************************************
    function densy(m, y, ireca)
      implicit real *8(a-h, o-z)
      common /hermt/afxt(22), afyt(22), afzt(22)
      common /hermd/afxm(20), afym(20), afzm(20)
      common /hermr/afxr(20), afyr(20), afzr(20)

      densy = 0.
      do k = 1, m
        kap = k - 1
        if (ireca==0) densy = densy + exp(-y*y/2.)*afyt(k)*herm(2*kap, abs(y))
        if (ireca==1) densy = densy + exp(-y*y/2.)*afym(k)*herm(2*kap, abs(y))
      end do
      return
    end function densy
    ! *******************************************************************
    ! FUNCTION denrs(XYZ)
    ! Specific function called by SCHERM
    ! Calculate the distribution :(n(x)+n(y)+n(z))/3. for the third
    ! ellipse
    ! *******************************************************************
    function denrs(xyz)
      implicit real *8(a-h, o-z)
      common /degherm/nmaz, nmazr, nmaxy

      sp1 = (densx(nmaxy,xyz,0)+densy(nmaxy,xyz,0))/3.
      sp2 = (densx(nmaxy,xyz,1)+densy(nmaxy,xyz,1))/3.
      denrs = sp1 - sp2 + densz(nmazr, xyz, 3)/3.
      return
    end function denrs
    ! *******************************************************************
    ! FUNCTION scgx(XI,XF)
    ! Specific function called by SCHERM
    ! Calculate the c.o.g in the x-direction for the third ellipse
    ! *******************************************************************
    function scgx(xi, xf)
      implicit real *8(a-h, o-z)
      common /degherm/nmaz, nmazr, nmaxy
      common /gaus13/h(13), t(13)

      cgx = 0.
      cgxx = 0.
      do i = 1, 13
        x = (xi+xf)/2. + (xf-xi)*t(i)/2.
        dend = (densx(nmaxy,x,0)-densx(nmaxy,x,1))
        cgx = cgx + h(i)*dend
        cgxx = cgxx + h(i)*dend*x
      end do
      cgx = cgx*(xf-xi)/2.
      cgxx = cgxx*(xf-xi)/2.
      scgx = cgxx/cgx
      return
    end function scgx
    ! *******************************************************************
    ! FUNCTION scgy(XI,XF)
    ! Specific function called by SCHERM
    ! Calculate the c.o.g in the y-direction for the third ellipse
    ! *******************************************************************
    function scgy(xi, xf)
      implicit real *8(a-h, o-z)
      common /degherm/nmaz, nmazr, nmaxy
      common /gaus13/h(13), t(13)

      cgy = 0.
      cgyy = 0.
      do i = 1, 13
        y = (xi+xf)/2. + (xf-xi)*t(i)/2.
        dend = (densy(nmaxy,y,0)-densy(nmaxy,y,1))
        cgy = cgy + h(i)*dend
        cgyy = cgyy + h(i)*dend*y
      end do
      cgy = cgy*(xf-xi)/2.
      cgyy = cgyy*(xf-xi)/2.
      scgy = cgyy/cgy
      return
    end function scgy
    ! *******************************************************************
    ! FUNCTION corxy(XI,XF,KAP,IK,XYRMS)
    ! Specific function called by SCHERM
    ! Calculate the Hermite coefficients for the third ellipse
    ! *******************************************************************
    function corxy(xi, xf, kap, ik, xyrms)
      implicit real *8(a-h, o-z)
      common /degherm/nmaz, nmazr, nmaxy
      common /gaus13/h(13), t(13)

      corxy = 0.
      k = kap - 1
      do i = 1, 13
        z = (xi+xf)/2. + (xf-xi)*t(i)/2.
        if (ik==0) dend = densx(nmaxy, z, 0) - densx(nmaxy, z, 1)
        if (ik==1) dend = densy(nmaxy, z, 0) - densy(nmaxy, z, 1)
        if (dend<0.) dend = 0.
        z = z/xyrms
        corxy = corxy + h(i)*herm(2*k, z)*dend
      end do
      corxy = corxy*(xf-xi)/2.
      return
    end function corxy
    ! *******************************************************************
    ! FUNCTION varxy(XI,XF,IK)
    ! Specific function called by SCHERM
    ! Calculate the Hermite coefficients for the residual part of the
    ! bunch
    ! *******************************************************************
    function varxy(xi, xf, ik)
      implicit real *8(a-h, o-z)
      common /gaus13/h(13), t(13)
      common /degherm/nmaz, nmazr, nmaxy

      varxy = 0.
      corxy1 = 0.
      corxy2 = 0.
      do i = 1, 13
        z = (xi+xf)/2. + (xf-xi)*t(i)/2.
        if (ik==0) dend = densx(nmaxy, z, 0) - densx(nmaxy, z, 1)
        if (ik==1) dend = densy(nmaxy, z, 0) - densy(nmaxy, z, 1)
        corxy1 = corxy1 + h(i)*z*z*dend
        corxy2 = corxy2 + h(i)*dend
      end do
      varxy = corxy1/corxy2
      return
    end function varxy
    ! *******************************************************************
    ! FUNCTION varzr(EE,CC,NMAZR)
    ! Specific function called by SCHERM
    ! Calculate the rms sizes of th residual part of the bunch
    ! *******************************************************************
    function varzr(ee, cc, nmazr)
      implicit real *8(a-h, o-z)

      varzr = 0.
      smt = densz(nmazr, 0.0d0, 3)/2.
      if (smt>0.) then
        smte = smt/1000.
        v1 = 0.
        v2 = cc - ee
20      z1 = (v1+v2)/2.
        spl = densz(nmazr, z1, 3)
        if (abs(spl-smt)<=smte) go to 10
        if (spl>smt) then
          v1 = z1
          go to 20
        end if
        if (spl<smt) then
          v2 = z1
          go to 20
        end if
10      continue
        varzr = 2.*z1/2.36
      else
        varzr = 0.
      end if
      return
    end function varzr
    ! *******************************************************************
    ! SUBROUTINE cdg(IDCH)
    ! Calculate the c.o.g. of the bunch
    ! IDCH EQ 1: WITH  CHASE
    ! IDCH NE 1: OTHERWISE
    ! cog(1) : Energy(MeV)
    ! cog(3) : t.o.f. (sec)
    ! cog(4) : x-direction (cm)
    ! cog(5) : xp(mrd)
    ! cog(6) : y-direction (cm)
    ! cog(7) : yp(mrd)
    ! *******************************************************************
    subroutine cdg(idch)
      implicit real *8(a-h, o-z)
      parameter(iptsz=100002, maxcell=3000, maxcell1=3000)
      common /faisc/f(10, iptsz), imax, ngood
      common /etcha1/dav2(maxcell1, 33), ichas(iptsz), chasit
      common /etcom/cog(8), exten(17), fd(iptsz)
      common /dyn/tref, vref
      logical chasit

      cog(1) = 0.
      cog(3) = 0.
      cog(4) = 0.
      cog(5) = 0.
      cog(6) = 0.
      cog(7) = 0.
      imaxf = 0
      if (idch==1.) then
        do i = 1, ngood
          if (ichas(i)==1) then
            cog(1) = cog(1) + f(7, i)
            cog(3) = cog(3) + f(6, i)
            cog(4) = cog(4) + f(2, i)
            cog(5) = cog(5) + f(3, i)
            cog(6) = cog(6) + f(4, i)
            cog(7) = cog(7) + f(5, i)
            imaxf = imaxf + 1
          end if
        end do
      else
        do i = 1, ngood
          cog(1) = cog(1) + f(7, i)
          cog(3) = cog(3) + f(6, i)
          cog(4) = cog(4) + f(2, i)
          cog(5) = cog(5) + f(3, i)
          cog(6) = cog(6) + f(4, i)
          cog(7) = cog(7) + f(5, i)
          imaxf = imaxf + 1
        end do
      end if
      cog(1) = cog(1)/imaxf
      cog(3) = cog(3)/imaxf
      cog(4) = cog(4)/imaxf
      cog(5) = cog(5)/imaxf
      cog(6) = cog(6)/imaxf
      cog(7) = cog(7)/imaxf
      return
    end subroutine cdg
    ! *******************************************************************
    ! SUBROUTINE ext2d(IDCH)
    ! Look for average extensions squared and return them in array exten
    ! Used in the routines: EMIPRT ETGAP RESTAY STATIS

    ! IDCH EQ 1: WITH  CHASE TEST
    ! IDCH NE 1: OTHERWISE

    ! cog(1) : Energy(MeV)
    ! cog(3) : t.o.f. (sec)
    ! cog(4) : x-direction (cm)
    ! cog(5) : xp(mrd)
    ! cog(6) : y-direction (cm)
    ! cog(7) : yp(mrd)

    ! exten(1) : Sum( dE*dE )  MeV*MeV
    ! exten(2) : Sum( dE*dPHase ) MeV*rad
    ! exten(3) : Sum( dPHase*dPHase ) rad*rad
    ! exten(4) : Sum( x*x )   cm*cm
    ! exten(5) : Sum( xp*xp )   mrad*mrad
    ! exten(6) : Sum( y*y )   cm*cm
    ! exten(7) : Sum( yp*yp )  mrad*mrad
    ! exten(8) : Sum( x*xp )   cm*mrad
    ! exten(9) : Sum( y*yp )   cm*mrad
    ! exten(12): Sum( (dp/p)*x(i) )  (cm), with p of REF
    ! exten(13): Sum( (dp/p)*y(i) )  (cm), with p of REF
    ! exten(14): Sum( (dp/p)*(dp/p) )  compared to p of REF
    ! exten(15): Sum( (dp/p)*x(i) )  (cm), with p of COG
    ! exten(16): Sum( (dp/p)*y(i) )  (cm), with p of COG
    ! exten(17): Sum( (dp/p)*(dp/p) )  compared to p of COG
    ! *******************************************************************
    subroutine ext2d(idch)
      implicit real *8(a-h, o-z)
      parameter(iptsz=100002, maxcell=3000, maxcell1=3000)
      common /consta/vl, pi, xmat, rpel, qst
      common /ttfc/tk, t1k, t2k, sk, s1k, s2k, fh
      common /faisc/f(10, iptsz), imax, ngood
      common /qmoyen/qmoy
      common /dyn/tref, vref
      common /dyni/vrefi, trefi, fhinit, acpt
      common /etcom/cog(8), exten(17), fd(iptsz)
      common /etcha1/dav2(maxcell1, 33), ichas(iptsz), chasit
      dimension ffd(iptsz)
      logical chasit, acpt

      exten(1) = 0.
      exten(2) = 0.
      exten(3) = 0.
      exten(4) = 0.
      exten(5) = 0.
      exten(6) = 0.
      exten(7) = 0.
      exten(8) = 0.
      exten(9) = 0.
      exten(12) = 0.
      exten(13) = 0.
      exten(14) = 0.
      exten(15) = 0.
      exten(16) = 0.
      exten(17) = 0.
      qmoy = 0.
      ! --- imaxf: particles keep in the bunch. With CHASE imaxf may be different from ngood(i.e. imaxf < ngood)
      imaxf = 0
      gcog = cog(1)/xmat
      bcog = sqrt(1.-1./(gcog*gcog))
      if (acpt) then
        bref = vrefi/vl
      else
        bref = vref/vl
      end if
      gref = 1./sqrt(1.-bref*bref)
      do i = 1, ngood
        gpai = f(7, i)/xmat
        if (gpai>1) then
          bpai = sqrt(1.-1./(gpai*gpai))
        else
          bpai = 0.
          gpai = 1.
        end if
        fd(i) = (gpai*bpai)/(gref*bref)
        ffd(i) = (gpai*bpai)/(gcog*bcog)
      end do
      do i = 1, ngood
        fdpp = fd(i) - 1.
        ffdpp = ffd(i) - 1.
        fdp = f(7, i) - cog(1)
        trph1 = fh*(f(6,i)-cog(3))
        trxf = f(2, i) - cog(4)
        trtf = f(3, i) - cog(5)
        tryf = f(4, i) - cog(6)
        trpf = f(5, i) - cog(7)
        ! --- with CHASE
        if (idch==1 .and. ichas(i)==1) then
          exten(1) = exten(1) + fdp**2
          exten(2) = exten(2) + trph1*fdp
          exten(3) = exten(3) + trph1**2
          exten(4) = exten(4) + trxf**2
          exten(5) = exten(5) + trtf**2
          exten(6) = exten(6) + tryf**2
          exten(7) = exten(7) + trpf**2
          exten(8) = exten(8) + trxf*trtf
          exten(9) = exten(9) + tryf*trpf
          exten(12) = exten(12) + fdpp*trxf
          exten(13) = exten(13) + fdpp*tryf
          exten(14) = exten(14) + fdpp**2
          exten(15) = exten(15) + ffdpp*trxf
          exten(16) = exten(16) + ffdpp*tryf
          exten(17) = exten(17) + ffdpp**2
          qmoy = qmoy + f(9, i)
          imaxf = imaxf + 1
        end if
        ! --- without CHASE
        if (idch/=1) then
          exten(1) = exten(1) + fdp**2
          exten(2) = exten(2) + trph1*fdp
          exten(3) = exten(3) + trph1**2
          exten(4) = exten(4) + trxf**2
          exten(5) = exten(5) + trtf**2
          exten(6) = exten(6) + tryf**2
          exten(7) = exten(7) + trpf**2
          exten(8) = exten(8) + trxf*trtf
          exten(9) = exten(9) + tryf*trpf
          exten(12) = exten(12) + fdpp*trxf
          exten(13) = exten(13) + fdpp*tryf
          exten(14) = exten(14) + fdpp**2
          exten(15) = exten(15) + ffdpp*trxf
          exten(16) = exten(16) + ffdpp*tryf
          exten(17) = exten(17) + ffdpp**2
          qmoy = qmoy + f(9, i)
          imaxf = imaxf + 1
        end if
      end do
      do i = 1, 9
        exten(i) = exten(i)/float(imaxf)
      end do
      do i = 12, 17
        exten(i) = exten(i)/float(imaxf)
      end do
      qmoy = qmoy/float(imaxf)
      return
    end subroutine ext2d
    ! *******************************************************************
    ! SUBROUTINE ext2(IDCH)
    ! Looks for average extensions squared and return them in array exten
    ! Used in the routines: stapl  tiltbm  ytzp

    ! IDCH EQ 1: WITH  CHASE TEST
    ! IDCH NE 1: OTHERWISE

    ! cog(1) : Energy(MeV)
    ! cog(3) : t.o.f. (sec)
    ! cog(4) : x-direction (cm)
    ! cog(5) : xp(mrd)
    ! cog(6) : y-direction (cm)
    ! cog(7) : yp(mrd)

    ! exten(1) : Sum( (dp/p)*(dp/p) ) compared to p of COG
    ! exten(2) : Sum( (dp/p)*phase )  (rad)
    ! exten(3) : Sum( phase*phase) ) (rad*rad)
    ! exten(4) : Sum( x(i)*x(i) )   cm*cm
    ! exten(5) : Sum( xp(i)*xp(i) )   mrad*mrad
    ! exten(6) : Sum( y(i)*y(i) )   cm*cm
    ! exten(7) : Sum( yp(i)*yp(i) )  mrad*mrad
    ! exten(8) : Sum( x(i)*xp(i) )   cm*mrad
    ! exten(9) : Sum( y(i)*yp(i) )   cm*mrad
    ! exten(10): Sum( dE*dE )        (MeV*MeV)
    ! exten(11): Sum( dE*phase )     (MeV*rad)
    ! exten(12): Sum( (dp/p)*x(i) )  (cm), with p of REF
    ! exten(13): Sum( (dp/p)*y(i) )  (cm), with p of REF
    ! exten(14): Sum( (dp/p)*(dp/p) ) compared to p of REF
    ! exten(15): Sum( (dp/p)*x(i) )  (cm), with p of COG
    ! exten(16): Sum( (dp/p)*y(i) )  (cm), with p of COG
    ! exten(17): Sum( (dp/p)*(dp/p) )  compared to p of COG
    ! *******************************************************************
    subroutine ext2(idch)
      implicit real *8(a-h, o-z)
      parameter(iptsz=100002, maxcell=3000, maxcell1=3000)
      common /consta/vl, pi, xmat, rpel, qst
      common /ttfc/tk, t1k, t2k, sk, s1k, s2k, fh
      common /faisc/f(10, iptsz), imax, ngood
      common /qmoyen/qmoy
      common /dyn/tref, vref
      common /dyni/vrefi, trefi, fhinit, acpt
      common /etcom/cog(8), exten(17), fd(iptsz)
      common /etcha1/dav2(maxcell1, 33), ichas(iptsz), chasit
      dimension fdd(iptsz)
      logical chasit, acpt
      ! EXT2 looks for average extensions squared and returns them in exten(14)
      exten(1) = 0.
      exten(2) = 0.
      exten(3) = 0.
      exten(4) = 0.
      exten(5) = 0.
      exten(6) = 0.
      exten(7) = 0.
      exten(8) = 0.
      exten(9) = 0.
      exten(10) = 0.
      exten(11) = 0.
      exten(12) = 0.
      exten(13) = 0.
      exten(14) = 0.
      exten(15) = 0.
      exten(16) = 0.
      exten(17) = 0.
      qmoy = 0.
      imaxf = 0
      gcog = cog(1)/xmat
      bcog = sqrt(1.-1./(gcog*gcog))
      if (acpt) then
        bref = vrefi/vl
      else
        bref = vref/vl
      end if
      gref = 1./sqrt(1.-bref*bref)
      do i = 1, ngood
        gpai = f(7, i)/xmat
        if (gpai>1) then
          bpai = sqrt(1.-1./(gpai*gpai))
        else
          bpai = 0.
          gpai = 1.
        end if
        fd(i) = (gpai*bpai)/(gcog*bcog)
        fdd(i) = (gpai*bpai)/(gref*bref)
      end do
      do i = 1, ngood
        fdp = fd(i) - 1.
        fddp = fdd(i) - 1.
        dener = f(7, i) - cog(1)
        trph1 = fh*(f(6,i)-cog(3))
        trxf = f(2, i) - cog(4)
        trtf = f(3, i) - cog(5)
        tryf = f(4, i) - cog(6)
        trpf = f(5, i) - cog(7)
        if (idch==1 .and. ichas(i)==1) then
          exten(1) = exten(1) + fdp**2
          exten(2) = exten(2) + trph1*fdp
          exten(3) = exten(3) + trph1**2
          exten(4) = exten(4) + trxf**2
          exten(5) = exten(5) + trtf**2
          exten(6) = exten(6) + tryf**2
          exten(7) = exten(7) + trpf**2
          exten(8) = exten(8) + trxf*trtf
          exten(9) = exten(9) + tryf*trpf
          exten(10) = exten(10) + dener*dener
          exten(11) = exten(11) + dener*trph1
          exten(12) = exten(12) + fddp*trxf
          exten(13) = exten(13) + fddp*tryf
          exten(14) = exten(14) + fddp**2
          exten(15) = exten(15) + fdp*trxf
          exten(16) = exten(16) + fdp*tryf
          exten(17) = exten(17) + fdp**2
          qmoy = qmoy + f(9, i)
          imaxf = imaxf + 1
        end if
        if (idch/=1) then
          exten(1) = exten(1) + fdp**2
          exten(2) = exten(2) + trph1*fdp
          exten(3) = exten(3) + trph1**2
          exten(4) = exten(4) + trxf**2
          exten(5) = exten(5) + trtf**2
          exten(6) = exten(6) + tryf**2
          exten(7) = exten(7) + trpf**2
          exten(8) = exten(8) + trxf*trtf
          exten(9) = exten(9) + tryf*trpf
          exten(10) = exten(10) + dener*dener
          exten(11) = exten(11) + dener*trph1
          exten(12) = exten(12) + fddp*trxf
          exten(13) = exten(13) + fddp*tryf
          exten(14) = exten(14) + fddp**2
          exten(15) = exten(15) + fdp*trxf
          exten(16) = exten(16) + fdp*tryf
          exten(17) = exten(17) + fdp**2
          qmoy = qmoy + f(9, i)
          imaxf = imaxf + 1
        end if
      end do
      do i = 1, 17
        exten(i) = exten(i)/float(imaxf)
      end do
      qmoy = qmoy/float(imaxf)
      return
    end subroutine ext2
    ! *******************************************************************
    ! SUBROUTINE chrefe
    ! change of reference frame
    ! ENTRY : XC YC A
    ! XC   : DISPLACEMENT IN THE HORIZONTAL DIRECTION (CM)
    ! YC   : DISPLACEMENT IN THE VERTICAL DIRECTION   (CM)
    ! A    : ROTATION ABOUT THE vertical AXIS         (DEG)
    ! *******************************************************************
    subroutine chrefe
      implicit real *8(a-h, o-z)
      parameter(iptsz=100002, maxcell=3000, maxcell1=3000)
      common /consta/vl, pi, xmat, rpel, qst
      common /faisc/f(10, iptsz), imax, ngood
      common /qmoyen/qmoy
      common /tapes/in, ifile, meta

      read (in, *) xc, yc, a
      a = a*pi/180.
      write (16, 100) xc, yc, a
      do i = 1, ngood
        x = f(2, i)
        xp = f(3, i)*0.001
        yp = f(5, i)*0.001
        y = f(4, i)
        x0 = x
        x = ((x-yc)*cos(xp)+xc*sin(xp))/cos(xp-a)
        xp = xp - a
        xl = xc - x*sin(a)
        yl = yc - x0 + x*cos(a)
        dl = sqrt(xl*xl+yl*yl)
        dl = sign(dl, xl)
        y = y + dl*tan(yp)
        f(2, i) = x
        f(3, i) = xp*1000.
        f(4, i) = y
        f(5, i) = yp*1000.
      end do
100   format (' New reference frame  XC =', f6.2, ' CM , YC =', f6.2, ' CM , A =', f6.4, ' RADIAN', ///)
      return
    end subroutine chrefe
    ! *******************************************************************
    ! SUBROUTINE etac
    ! Several charge states in the  bunch, generated randomly
    ! ENTRY :
    ! N       : Number of charge states (maximum 6 different charge states)
    ! CHARGE(I)  PCENT(I)  EOFF (I = 1 to N )
    ! CHARGE(I)    : charge state
    ! PCENT(I)     : percentage of charge state
    ! EOFF(I)      : absolute energy offset of charge state w.r.t. COG (MeV)
    ! ix           : RANDOM NUMBER GENERATOR
    ! *******************************************************************
    subroutine etac
      implicit real *8(a-h, o-z)
      parameter(iptsz=100002, maxcell=3000, maxcell1=3000)
      common /consta/vl, pi, xmat, rpel, qst
      common /faisc/f(10, iptsz), imax, ngood
      common /qmoyen/qmoy
      common /tapes/in, ifile, meta
      common /mcs/imcs, ncstat, cstat(20)
      dimension charge(20), pcent(20), charm(20), pc(20), eoff(20), vecx(1)
      dimension foo(20, 9), ndp(20)
      character *80 myfile

      read (in, *) ncstat
      n = ncstat
      if (n>20) then
        write (16, 140) n
        stop
      end if
      imcs = 1
      if (n==0) then
        ! read charge state distribution from file
        read (in, 3333) myfile(1:80)
3333    format (a80)
        write (16, *) 'Charge state distribution file: ', myfile(1:80)
        open (56, file=myfile, status='unknown')
        read (56, *) ntot
        write (16, *) 'Maximum number of particles:', imax
        write (16, *) 'Number  of   good particles:', ngood
        write (16, *) 'Number of particles in charge state file:', ntot
        if (ntot<ngood) then
          write (16, *) 'Not enough particles in charge state file'
          stop
        end if
        do j = 1, ntot
          read (56, *) chstate
          f(9, i) = chstate
        end do
        close (56)
      else
        ! generate charge state distribution
        pourc = 0.
        do i = 1, n
          ! for each charge state read charge, percentage and energy offset
          read (in, *) charm(i), pc(i), eoff(i)
          cstat(i) = charm(i)
          pourc = pourc + pc(i)
          if (pourc>100.) then
            write (16, 100) i, pourc
            stop
          end if
        end do
        pourc = 0.
        do i = 1, n
          ! WRITE(16,110) charm(I),PC(I),eoff(i)
          pourc = pourc + pc(i)
        end do
        if (pourc/=100.) then
          write (16, 120) pourc
          stop
        end if
        j = 1
25      continue
        ts = 500.
        is = 1
        do i = 1, n
          if (ts>=charm(i)) then
            ts = charm(i)
            is = i
          end if
        end do
        charge(j) = ts
        pcent(j) = pc(is)
        charm(is) = 1000.
        j = j + 1
        if (j<=n) go to 25
        write (16, *) '**********************'
        ! for each charge state write charge, percentage and energy offset
        jjj = 0
        do i = 1, n
          write (16, 110) charge(i), pcent(i), eoff(i)
          if (charge(i)==qst) jjj = 1
        end do
        len = 1
        ! FIRST TRAJECTORY HAS CHARGE STATE AS DEFINED BY INPUT
        pcent(1) = pcent(1)/100.
        do i = 2, n
          pcent(i) = pcent(i-1) + pcent(i)/100.
        end do
        do i = 1, imax
          call rlux(vecx, len)
          xarpha = vecx(1)
          if (xarpha<=pcent(1)) then
            f(9, i) = charge(1)
            f(7, i) = f(7, i) + eoff(1)
          else
            do j = 1, n - 1
              if (xarpha>pcent(j) .and. xarpha<=pcent(j+1)) then
                f(7, i) = f(7, i) + eoff(j+1)
                f(9, i) = charge(j+1)
              end if
            end do
          end if
        end do
      end if
      ! print energy, boro for each charge state
      do k = 1, ncstat
        ndp(k) = 0
        do j = 2, 7
          foo(k, j) = 0.
        end do
      end do
      do i = 1, imax
        do k = 1, ncstat
          if (f(9,i)==cstat(k)) then
            ndp(k) = ndp(k) + 1
            do j = 2, 7
              foo(k, j) = foo(k, j) + f(j, i)
            end do
          end if
        end do
      end do
      do k = 1, ncstat
        do j = 2, 7
          foo(k, j) = foo(k, j)/float(ndp(k))
        end do
      end do
      do k = 1, ncstat
        gref = foo(k, 7)/xmat
        bref = sqrt(1.-1./(gref*gref))
        xe = (gref-1.)*xmat
        ! magnetic rigidity
        bor = 3.3356*xmat*bref*gref/cstat(k)
        write (16, *) ' Q: ', cstat(k), ' COG : energy ', xe, ' MeV  momentum ', bor, ' kG.cm'
      end do
100   format (3x, ' WRONG PERCENTAGE IN CHARGE STATE DISTRIBUTION', /, 4x, ' CHARGE STATE ', i3, ' PERCENTAGE ', e12.5)
110   format (3x, ' CHARGE STATE ', f6.1, '  PERCENTAGE ', e12.5, ' %', 4x, ' ENERGY OFFSET ', e12.5, ' MeV')
120   format (3x, ' TOTAL PERCENTAGE OF ALL CHARGE STATES < 100 %', /, 4x, ' PERCENTAGE ', e12.5)
140   format (3x, ' NUMBER OF CHARGE STATES : ', i3, ' GREATER THAN 20')
      return
    end subroutine etac
    ! *******************************************************************
    ! SUBROUTINE crest(betr,eqvl,xpos,bkcr,ffield)
    ! called by RESTAY
    ! Look for the beta giving the maximun energy gain
    ! iterative method
    ! *******************************************************************
    subroutine crest(betr, eqvl, xpos, bkcr, ffield)
      implicit real *8(a-h, o-z)
      common /ttfc/tk, t1k, t2k, sk, s1k, s2k, fh
      common /func/a(200), ylg, atte, ncel, nharm
      common /consta/vl, pi, xmat, rpel, qst

      xlhe = ylg
      itr = 0
      be1 = betr
      be2 = betr - 8.333e-03*betr
      xleq = xlhe
456   continue
      itr = itr + 1
      xk1 = fh/(vl*be1)
      xk2 = fh/(vl*be2)
      t1 = tta0(be1)*ffield
      s1 = tsb0(be1)*ffield
      tp1 = tta1(be1)*ffield
      sp1 = tsb1(be1)*ffield
      t2 = tta0(be2)*ffield
      s2 = tsb0(be2)*ffield
      tp2 = tta1(be2)*ffield
      sp2 = tsb1(be2)*ffield
      dts = (t1*tp1+s1*sp1)/(t1*t1+s1*s1)
      a1k12 = (t1*tp1+s1*sp1)/(t2*tp2+s2*sp2)
      a2k12 = (t2*t2+s2*s2)/(t1*t1+s1*s1)
      ak12 = a1k12*a2k12
      ak12 = 1./ak12
      bk12 = (xk2-xk1)/(ak12-1.)
      bk12 = bk12*dts
      desy = -4.*atan(dts*3.2/xleq)
      ! improve  DESYNCHRONISATION
      epsrd = 1.e-04
      if (abs(desy)>=epsrd) then
        til2 = desy/2.
        do iii = 1, 3
          ftil = til2/tan(til2) - 1. - bk12
          dftil = -til2/(sin(til2)*sin(til2)) + 1./tan(til2)
          til2 = til2 - ftil/dftil
        end do
        desy = til2*2.
      end if
      if (abs(desy)<epsrd) then
        xpos = (t1*sp1-s1*tp1)/(t1*t1+s1*s1)
        bkcr = sqrt(t1*t1+s1*s1)
        eqvl = xleq
        return
      end if
      ! calculates the equivalent length
      xleq = desy*(ak12-1.)/(xk2-xk1)
      deltk = desy/xleq
      xkcrt = xk1 - deltk
      becrt = fh/(vl*xkcrt)
      be1 = becrt
      be2 = becrt - becrt/120.
      go to 456
    end subroutine crest
    ! *******************************************************************
    ! SUBROUTINE gaus(r1,r2,z1,z2,opt,er,ez)
    ! called by SCHEFF
    ! calculate er and ez at the r and z location given in fldcom
    ! by gauss quadrature integration over the double
    ! interval from r1 to r2 and from z1 to z2.
    ! if opt.gt.0, determine number of integration points as follows.
    ! let rat = max(cr/cz,cz/cr), where cr=r2-r1, and cz=z2-z1
    ! if rat.le.2, use 2 x 2 point array
    ! if rat.gt.2, use 2 x 4 point array
    ! if rat.gt.4, use 2 x 6 point array
    ! if opt.lt.0, use 2 x 2 point array regardless of rat
    ! *******************************************************************
    subroutine gaus(r1, r2, z1, z2, opt, er, ez)
      implicit real *8(a-h, o-z)
      parameter(iptsz=100002, maxcell=3000, maxcell1=3000)
      dimension r(6), z(6), wr(6), wz(6), xx(3, 3), wx(3, 3)
      data ((xx(i,j),i=1,3), j=1, 3)/.2113248654, 0.0, 0.0, .06943184420, .33000947820, 0.0, .03376524290, .16939530680, &
        .3806904070/
      data ((wx(i,j),i=1,3), j=1, 3)/.50, 0.0, 0.0, .17392742260, .32607257740, 0.0, .085662246190, .1803807865000, &
        .2339569673000/

      cr = r2 - r1
      cz = z2 - z1
      ir = 1
      jz = 1
      m = 1
      if (opt<0.) go to 20
      ! ---determine number of integration points
      rat = abs(cz/cr)
      l = 0
      if (rat>=1.) go to 10
      rat = 1./rat
      l = 1
10    if (rat>2.) m = 2
      if (rat>4.) m = 3
      if (l==0) jz = m
      if (l==1) ir = m
20    do i = 1, ir
        k = 2*i - 1
        r(k) = r1 + cr*xx(i, ir)
        r(k+1) = r2 - cr*xx(i, ir)
        wr(k) = wx(i, ir)
        wr(k+1) = wx(i, ir)
      end do
      do j = 1, jz
        k = 2*j - 1
        z(k) = z1 + cz*xx(j, jz)
        z(k+1) = z2 - cz*xx(j, jz)
        wz(k) = wx(j, jz)
        wz(k+1) = wx(j, jz)
      end do
      ser = 0.
      sez = 0.
      kr = 2*ir
      kz = 2*jz
      do i = 1, kr
        do j = 1, kz
          call flds(r(i), z(j), er1, ez1)
          ser = ser + wr(i)*wz(j)*er1*r(i)
          sez = sez + wr(i)*wz(j)*ez1*r(i)
        end do
      end do
      er = cr*cz*ser
      ez = cr*cz*sez
      return
    end subroutine gaus
    ! *******************************************************************
    ! SUBROUTINE flds(r,z,er,ez)
    ! called by SCHEFF
    ! evaluate fields at r1,z1 due to ring of charge at r,z.
    ! er=(pi/2)*r/d**3.     ez=(pi/2)*z/d**3.
    ! *******************************************************************
    subroutine flds(r, z, er, ez)
      implicit real *8(a-h, o-z)
      parameter(iptsz=100002, maxcell=3000, maxcell1=3000)
      common /fldcom/rp, zp, pl, opt, nip

      r1 = rp
      z1 = zp
      ! **********************************
      d = z1 - z
      c = (r1-r)**2
      b = (r1+r)**2
      a = 4.0*r*r1/(b+d**2)
      call eint(a, ee, ek)
      er1 = 0.0
      a = sqrt(b+d**2)
      if (r1==0.) go to 10
      er1 = (ek-(r**2-r1**2+d**2)*ee/(c+d**2))/(2.0*r1*a)
10    ez1 = d*ee/(a*(c+d**2))
      if (nip==0) go to 50
      do i = 1, nip
        xi = i
        do j = 1, 2
          d = z1 - (z+xi*pl)
          a = 4.0*r*r1/(b+d**2)
          call eint(a, ee, ek)
          a = sqrt(b+d**2)
          if (r1==0.) go to 20
          er1 = er1 + (ek-(r**2-r1**2+d**2)*ee/(c+d**2))/(2.0*r1*a)
20        ez1 = ez1 + d*ee/(a*(c+d**2))
          xi = -xi
        end do
      end do
50    er = er1
      ez = ez1
      return
    end subroutine flds
    ! *******************************************************************
    ! SUBROUTINE eint(a,ee,ek)
    ! evaluate elliptic integrals  ( called by SCHEFF)
    ! *******************************************************************
    subroutine eint(a, ee, ek)
      implicit real *8(a-h, o-z)
      parameter(iptsz=100002, maxcell=3000, maxcell1=3000)

      b = 1.0 - a
      c = log(b)
      ee = 1.0 + b*(.4630106-0.2452740*c+b*(0.1077857-0.04125321*c))
      ek = 1.38629436 - .5*c + b*(0.1119697-0.1213486*c+b*(.07253230-.028874721*c))
      return
    end subroutine eint
    ! *******************************************************************
    ! SUBROUTINE tiltz(tilta)
    ! Skew the right ellipse generated by GEBEAM in the phase plane (x,z)
    ! *******************************************************************
    subroutine tiltz(tilta)
      implicit real *8(a-h, o-z)
      parameter(iptsz=100002, maxcell=3000, maxcell1=3000)
      common /consta/vl, pi, xmat, rpel, qst
      common /faisc/f(10, iptsz), imax, ngood
      common /qmoyen/qmoy
      common /rigid/boro
      common /dyn/tref, vref
      common /tapes/in, ifile, meta
      common /etcom/cog(8), exten(17), fd(iptsz)

      write (16, 1) tilta
1     format (' tilt in the plane (x,z) around the c.o.g', '    ANGLE :', e12.5, ' DEG', /)
      tilta = tilta*pi/180.
      tref = 0.
      vref = 0.
      do i = 1, imax
        gpai = f(7, i)/xmat
        vref = vref + vl*sqrt(1.-1./(gpai*gpai))
        tref = tref + f(6, i)
      end do
      vref = vref/float(imax)
      tref = tref/float(imax)
      vref1 = 0.
      tref1 = 0.
      do i = 1, imax
        gpai = f(7, i)/xmat
        vpai = sqrt(1.-1./(gpai*gpai))*vl
        trot = (f(6,i)-tref)*cos(tilta) - sin(tilta)*f(2, i)/vpai
        xrot = (f(6,i)-tref)*sin(tilta)*vpai + cos(tilta)*f(2, i)
        f(6, i) = trot
        f(2, i) = xrot
        tref1 = tref1 + f(6, i)
        vref1 = vref1 + vpai
      end do
      tref = tref1/float(imax)
      vref = vref1/float(imax)
      return
    end subroutine tiltz
    ! *******************************************************************
    ! SUBROUTINE rfq_o3
    ! Dynamics through a single cell of a RFQ with multipolar expansion
    ! units: MeV , m , sec
    ! p(1): V/(r0*r0)  (MV/m2)
    ! p(2): AV (MV)
    ! p(3): cell length CL (m)
    ! p(4): phase of RF  at the entrance of the cell (deg)
    ! p(5): TYPE
    ! TYPE IS 0, 1., 2., OR 3., INDICATING AS FOLLOWS
    ! 0, STANDARD CELL, NO ACCELERATION
    ! 1, STANDARD CELL, ACCELERATION
    ! 2, FRINGE-FIELD, NO ACCELERATION
    ! 3, FRINGE FIELD, ACCELERATION
    ! *******************************************************************
    subroutine rfq_o3
      implicit real *8(a-h, o-z)
      parameter(iptsz=100002, maxcell=3000, maxcell1=3000)
      common /rigid/boro
      common /consta/vl, pi, xmat, rpel, qst
      common /dyn/tref, vref
      common /ttfc/tk, t1k, t2k, sk, s1k, s2k, fh
      common /faisc/f(10, iptsz), imax, ngood
      common /tapes/in, ifile, meta
      common /davcom/dav1(maxcell1, 40), davtot, iitem(maxcell1), idav
      common /etcom/cog(8), exten(17), fd(iptsz)
      common /sc3/beamc, scdist, sce10, cplm, ect, apl, ichaes, iscsp
      common /fene/wdisp, wphas, wx, wy, rlim, ifw
      common /dcspa/iesp
      common /pltprf/sprfx(3000), sprfy(3000), sprfl(3000), sprfw(3000), sprfp(3000), sprng(3000), iprf
      common /compt/nrres, nrtre, nrbunc, nrdbun
      common /shif/dtiph, shift
      common /femt/iemgrw, iemqesg
      common /posc/xpsc
      common /cgtof/charm(20), cgtdv(20), nbch(20), netac
      common /drfq/p(9)
      character *1 cr
      common /azlist/icont, iprin
      common /trfq/icour, ncell
      logical iesp, ichaes, shift, iemgrw, iflag
      common /itvole/itvol, imamin
      common /tofev/ttvols
      logical itvol, imamin
      ! allow for print out on terminal of gap# on one and the same line
      cr = char(13)
      ! omment       WRITE(6,8254) NRTRE,NRRES,cr
      ! write(6,8254) nrtre,ncell,cr
      ! 8254   format('Transport element:',i5,
      ! *        '      RFQ cell            :',i5,a1,$)
      iflag = .false.
      radian = pi/180.
      ilost = 0
      twopi = 2.*pi
      ! convert vl in m
      vlm = vl/100.
      ! STATISTIQUES FOR PLOTS
      if (iprf==1) call stapl(davtot*10.)
      vorsq = p(1)
      av = p(2)
      cl = p(3)
      type = p(5)
      write (16, *) '*** cell :', ncell + 1, ' length (cm): ', cl*100.
      write (16, *) '*** V/r0**2  (kV/mm**2): ', vorsq/1000.
      write (16, *) '*** AV (kV): ', av*1000.
      if (type==0.) write (16, *) '*** no acceleration, standard cell '
      if (type==1.) write (16, *) '*** acceleration, standard cell '
      if (type==2.) write (16, *) '*** no acceleration, fringing field region '
      if (type==3.) write (16, *) '*** acceleration, fringing field region '
      wavel = 2.*pi*vlm/fh
      er = xmat
      cay = pi/cl
      ns = 18
      xl = cl/float(ns)
      hl = .5*xl
      ! ----  scl: space charge length (in cm SCHEFF unit)
      scl = cl*100.
      ! ----  c.o.g of the bunch at the entrance of the cell
      tcog = 0.
      ecog = 0.
      ! old        qcog=0.
      do i = 1, ngood
        tcog = tcog + f(6, i)
        ecog = ecog + f(7, i)
        ! old         qcog=qcog+f(9,i)
      end do
      tcog = tcog/float(ngood)
      ecog = ecog/float(ngood)
      ! old        qcog=qcog/float(ngood)
      gcog = ecog/er
      bcog = sqrt(1.-1./(gcog*gcog))
      wcog = ecog - er
      if (ncell==0) then
        ! ---- shift = .false. ==> synchronous particle coincide with cog in the cell ncell = 0
        if (.not. shift) then
          write (16, *) '*** ref. part. and cog coincide in ncell = 0'
          tref = tcog
          bref = bcog
          vref = bref*vl
          gref = gcog
          wref = wcog
          wrefi = wref
        else
          ! ---- shift = .true. ==> the reference particle and the cog are different at the entrance of the RFQ
          write (16, *) '*** ref. part. and cog separated  in ncell = 0'
          bref = vref/vl
          gref = 1./sqrt(1.-bref*bref)
          wref = er*(gref-1.)
          wrefi = wref
        end if
      end if
      if (type>1.) then
        cay = .5*cay
        ns = int(36.*cl/(bref*wavel))
      end if
      write (16, 178)
178   format (/, ' Dynamics at input', /, 5x, '   BETA     GAMMA      ENERGY(MeV) ', '       TOF(deg)     TOF(sec)')
      write (16, 1788) bcog, gcog, wcog, tcog*fh*180./pi, tcog
1788  format (' COG ', f7.5, 3x, e12.5, 1x, e12.5, 3x, e12.5, 3x, e12.5)
      write (16, 165) bref, gref, wref, tref*fh*180./pi, tref
165   format (' REF ', f7.5, 3x, e12.5, 1x, e12.5, 3x, e12.5, 3x, e12.5)
      ! start prints in file 'short.data'
      idav = idav + 1
      iitem(idav) = 14
      dav1(idav, 1) = cl*1000.
      dav1(idav, 2) = vorsq/1000.
      dav1(idav, 3) = av*1000
      davtot = davtot + cl*100.
      dav1(idav, 4) = davtot*10.
      dav1(idav, 5) = type
      ! ----  phini: phase of the reference at input of the cell
      phini = -tref*fh + p(4)*radian
      ph0 = phini*180./pi
      write (16, 3945) ph0, p(4)
3945  format ('phase offset at input : ', e12.5, ' deg phase shift: ', e12.5, ' deg')
      ! --- the cell is divided in ns elements of length xl(m)
      z = 0.
      do n = 1, ns
        z = z + hl
        ! ---- change of synchronous particle over the half step hl = xl/2
        tref = tref + hl/(bref*vlm)
        if (itvol) ttvols = tref
        phref = tref*fh + phini
        skz = sin(cay*z)
        ckz = cos(cay*z)
        ! ---    cell with fringing field (TYPE > 1)
        if (type>1.) then
          c3kz = cos(3.*cay*z)
          skz = .75*(skz+sin(3.*cay*z))
        end if
        ! ------  CHANGE OF ENERGY OVER STEP XL
        if (type/=0. .and. type/=2.) then
          sp = sin(phref)
          dwref = .5*qst*cay*av*skz*sp*xl
          wrefm = wref + 0.5*dwref
          grefm = wrefm/er + 1.
          brefm = sqrt(1.-1./(grefm*grefm))
          wref = wref + dwref
          gref = wref/er + 1.
          bref = sqrt(1.-1./(gref*gref))
          ! c         dez=.5*qst*cay*av*skz*sp
          ! c         dref=.5*(dez/er) * xl*xl/(brefm**3*grefm**3*vlm)
        end if
        ! start computations of particles
        do ip = 1, ngood
          ! convert in m and rad
          xi = f(2, ip)*1.e-02
          xpi = f(3, ip)*1.e-03
          yi = f(4, ip)*1.e-02
          ypi = f(5, ip)*1.e-03
          ww = f(7, ip) - er
          gi = ww/er + 1.
          bi = sqrt(1.-1./(gi*gi))
          bgi = bi*gi
          tim = f(6, ip) + hl/(bi*vlm)
          phi = phini + fh*tim
          qq = abs(f(9,ip))
          sp = sin(phi)
          cp = cos(phi)
          bav = bi
          gav = gi
          bgav = bgi
          bg = bgi
          beta = bi
          delt = 0.
          amort = 1.
          xm = xi + xpi*hl
          ym = yi + ypi*hl
          rm = sqrt(xm*xm+ym*ym)
          ! ---- the particle is lost if rm>rlim (rlim is the limit of REJECT)
          ! rlim is converted in m
          ! rlimm=rlim*1.e-02
          if (rm>rlimm) then
            f(8, ip) = 0.
            iflag = .true.
            ilost = ilost + 1
            write (16, 5556) ip, rm, rlimm
5556        format (' particle lost: ', i5, ' radius (m): ', e12.5, ' barrier (m):', e12.5)
            go to 6525
          end if
          theta = 0.
          xml = xm
          yml = ym
          if (abs(xm)>1.e-10) theta = atan(ym/xm)
          if (abs(xm)<=1.e-10) then
            if (abs(ym)>1.e-10) then
              if (xm>=0. .and. ym>0.) theta = pi/2
              if (xm>=0. .and. ym<0.) theta = -pi/2
              if (xm<0. .and. ym<0.) theta = pi/2
              if (xm<0. .and. ym>0.) theta = -pi/2
            end if
            if (abs(ym)<=1.e-10) theta = 0.
          end if
          zrm = cay*rm
          ! ----- Bessel functions I0 and I1
          ! omment          bi0=1.+zrm*zrm/4.+zrm**4/64.+zrm**6/2304.+zrm**8/1.47456e05
          bi0 = 1. + zrm*zrm/4. + zrm**4/64. + zrm**6/2304.
          bi1 = zrm/2. + zrm**3/16.
          ! transverse fields ex and ey
          erf = vorsq*cos(2.*theta)*2.*rm + cay*(av*bi1)*ckz
          erf = -erf/2.
          etf = vorsq*sin(theta)*2.*rm
          etf = etf/2.
          ex = erf*cos(theta) - etf*sin(theta)
          ey = erf*sin(theta) + etf*cos(theta)
          ! ----  change the energy over step xl
          if (type/=0. .and. type/=2.) then
            ! ----  energy at the middle of the element
            ! ------ standard cell
            if (type<2.) then
              ez = 0.5*(av*bi0)*skz*cay
              dw = qq*ez*sp*xl
              ! ------ fringe-field cell
            else
              dw = .5*qq*cay*avb*skz*sp*xl
            end if
            wav = ww + .5*dw
            ga = wav/er
            bgav = sqrt(ga*(2.+ga))
            gav = 1. + ga
            bav = bgav/gav
            ! ---- energy over the step xl
            ww = ww + dw
            ga = ww/er
            gam = 1. + ga
            bg = sqrt(ga*(2.+ga))
            beta = sqrt(1.-1/(gam*gam))
            ! calculate the jump of phase (in sec)
            if (type<2.) dez = qq*ez*sp
            if (type>2.) dez = .5*qq*cay*avb*skz*sp
            delt = .5*(dez/er)*xl*xl/(bav**3*gav**3*vlm)
            amort = bgi/bg
          end if
          bgfac = gav*bav**2
          ! ----- IF TYPE LT 2: standard cell
          if (type<2.) then
            cc = qq*xl*sp/(bgfac*er)
            signx = 1.
            signy = 1.
            if (theta>0.) then
              if (xm<0.) signx = -1.
              if (ym<0.) signy = -1.
            end if
            if (theta<0.) then
              if (xm<0.) signx = -1.
              if (ym>0.) signy = -1.
            end if
            if (theta==0.) then
              signx = 0.
              signy = 0.
            end if
            rr1 = cc*ex*signx
            rr2 = cc*ey*signy
            xpm = xpi*amort + rr1
            ypm = ypi*amort + rr2
          else
            ! ----- fringe-field cell (first order in transverse directions)
            ! *********************************************************
            ! C1 = (1/m**2) * (m) = (1/m)
            ! C2 = (1/m**2) * (m) = (1/m)
            ! RF1 = (MeV/(MeV*m**2)) = (1/m**2)
            ! RF2 =  (MeV/MeV) * (1/m**2) = (1/m**2)
            ! *******************************************************
            rf1 = qq*vorb/er
            rf2 = .25*qq*cay*cay*avb/er
            c1 = rf1*sp*xl/bgfac
            c2 = rf2*ckz*sp*xl/bgfac
            c1 = c1*.75*(ckz+c3kz/3.)
            c2 = c2*.75*(ckz+3.*c3kz)
            rr1 = -(c1+c2)
            rr2 = (c1-c2)
            xpm = xpi*amort + rr1*xm
            ypm = ypi*amort + rr2*ym
          end if
          xf = xm + xpm*hl
          yf = ym + ypm*hl
          ! convert m->cm , rad->mrad
          f(2, ip) = xf*100.
          f(4, ip) = yf*100.
          f(3, ip) = xpm*1000.
          f(5, ip) = ypm*1000.
          ! tof over the length xl
          f(6, ip) = f(6, ip) + hl/(bi*vlm) + hl/(beta*vlm) + delt
          f(7, ip) = ww + er
          ! ----- print in file 49 coordinates of particle icont (not active)
          ! omment         if(ip.eq.icont) then
          ! omment         write(49,8888)n,icour,z,signx,signy,ex,ey,theta,xml,yml,rr1,rr2
          ! omment          icour=icour+1
          ! omment         endif
          ! omment8888      format(2(2x,i5),10(2x,e12.5))
          ! ---- ********************************************************************
6525      continue
        end do
        ! ----- reshuffle good particles
        if (iflag) then
          call shuffle
          iflag = .false.
        end if
        ! space charge at the middle of the cell  (revoir pour fringe field cell)
        if (n==9) then
          if (ichaes) then
            ! Charge space
            iesp = .true.
            call cesp(scl)
            iesp = .false.
          end if
        end if
        tref = tref + hl/(bref*vlm) + dref
        if (itvol) ttvols = tref
        vref = bref*vl
        z = z + hl
        ! Change  dp/p over the cell
        call disp
      end do
      ! ---  kept in the bunch particles such that phase RF > 180 deg or phase RF < -180 deg
      do i = 1, ngood
        dtvl = (f(6,i)-tref)*fh
        if (dtvl>pi) f(6, i) = f(6, i) - 2.*pi/fh
        if (dtvl<-pi) f(6, i) = f(6, i) + 2.*pi/fh
      end do
      ! ----  c.o.g of the bunch at the output of the cell
      tcog = 0.
      ecog = 0.
      do i = 1, ngood
        tcog = tcog + f(6, i)
        ecog = ecog + f(7, i)
      end do
      tcog = tcog/float(ngood)
      ecog = ecog/float(ngood)
      gcog = ecog/er
      bcog = sqrt(1.-1./(gcog*gcog))
      wcog = ecog - er
      ! ---  window control relative to the energy of the c.o.g of the bunch
      ! ---- ifw = 0 ===> wdisp = dW/W
      ! ---- ifw = 1 ===> wdisp = dW (MeV)
      ! ----- convert wdisp in dp/p
      if (ifw==0) dispr = gcog*gcog*wdisp/(gcog*(gcog+1.))
      if (ifw==1) dispr = gcog*gcog*wdisp/(gcog*(gcog+1.)*wcog)
      iflag = .false.
      do i = 1, ngood
        dese = abs(fd(i)-1.)
        if (dese>dispr) then
          ilost = ilost + 1
          f(8, i) = 0.
          write (16, *) ' particle lost: ', i, ' dp/p: ', dese, ' in window :', dispr
          iflag = .true.
        end if
      end do
      if (iflag) then
        call shuffle
        ! ----  c.o.g of the bunch after shuffle
        tcog = 0.
        ecog = 0.
        do i = 1, ngood
          tcog = tcog + f(6, i)
          ecog = ecog + f(7, i)
        end do
        tcog = tcog/float(ngood)
        ecog = ecog/float(ngood)
        gcog = ecog/er
        bcog = sqrt(1.-1./(gcog*gcog))
        wcog = ecog - er
      end if
      write (16, 179)
179   format (/, ' Dynamics at the output', /, 5x, '   BETA     GAMMA      ENERGY(MeV) ', &
        '       TOF(deg)     TOF(sec)')
      write (16, 1788) bcog, gcog, wcog, tcog*fh*180./pi, tcog
      write (16, 165) bref, gref, wref, tref*fh*180./pi, tref
      write (16, *) '  time of flight: ', ttvols*fh*180./pi, ' deg'

      ! et2010s
      ! dphete,dav1(idav,16),dav1(idav,21) and dav1(idav,12) still to be assigned correct value
      dphete = 0.
      emns = 0.
      tofprt = fh*tcog*180./pi
      n2kp = int(tofprt/360.)
      tofprt = tofprt - float(n2kp)*360.
      if (tofprt>180.) tofprt = tofprt - 360.
      ! cavity number, transmission (%), synchronous phase (deg), time of flight (deg) (within –180 deg and 180 deg),
      ! COG relativistic beta (@ output), COG output energy (MeV), REF relativistic beta (@ output), REF output energy
      ! (MeV),
      ! horizontal emittance (mm.mrad, RMS normalized), vertical emittance (mm.mrad, RMS normalized),
      ! longitudinal emittance (RMS, ns.keV) <- still to be implemented (=emns)
      trnsms = 100.*float(ngood)/float(imax)
      if (ncell==1) write (50, *) '# rfq_o3.dmp'
      write (50, 7023) ncell, trnsms, p(4), tofprt, bcog, wccog, bets, wref, 0.25*dav1(idav, 16), 0.25*dav1(idav, 21), &
        0.25*emns
7023  format (1x, i4, 1x, f6.2, 2(1x,f8.3), 2(1x,f7.5,1x,f11.4), 3(1x,f11.4))
      ! et2010e

      ! ----  new magnetic rigidity of the reference
      xmor = xmat*bref*gref
      boro = 33.356*xmor*1.e-01/qst
      dav1(idav, 6) = (gref-1.)*er - wrefi
      dav1(idav, 36) = ngood
      ! plots
      call stapl(davtot*10.)
      call emiprt(0)
      ncell = ncell + 1
      return
    end subroutine rfq_o3
    ! *******************************************************************
    ! SUBROUTINE tdens(m,ireca,iacc)
    ! called by SCHERM
    ! Look for the shape of the distribution n(t)
    ! ireca=0 : for the first ellipse
    ! ireca=1 : for the second ellipse
    ! *******************************************************************
    subroutine tdens(m, ireca, iacc)
      implicit real *8(a-h, o-z)
      common /hermt/afxt(22), afyt(22), afzt(22)
      common /hermd/afxm(20), afym(20), afzm(20)
      common /hermr/afxr(20), afyr(20), afzr(20)
      common /sizp/xrms1, yrms1, zrms1, xrms2, yrms2, zrms2, imaxd
      common /consta/vl, pi, xmat, rpel, qst

      iacc = 0
      t = 1.e-05
      dt = 5.e-02
      fc = drxyz(m, t, ireca)
      f1 = fc
      do i = 1, 100
        t = t + dt
        fu = drxyz(m, t, ireca)
        if (fu>=fc) then
          fc = fu
          go to 10
        end if
        go to 11
10    end do
11    continue
      if (abs(fc/f1)>1.2) iacc = 1
      return
    end subroutine tdens
    ! *******************************************************************
    ! SUBROUTINE schfdyn
    ! Input datas for SCHEFF
    ! SCE(2)=r extension in rms multiples
    ! SCE(3)=z half extension in rms multiples
    ! SCE(4)=no. of radial mesh intervals (le 20)
    ! SCE(5)=no. of longitudinal mesh intervals (le 40)
    ! sce(6)=no. of adjacent bunches, applicable for buncher studies
    ! and should be 0 for linac dynamics
    ! sce(7)=pulse length, if not beta lambda.(transport studies)
    ! distance bewteen beam pulses
    ! input zero to get default "beta lambda"
    ! units are cm
    ! sce(8)=dummy
    ! sce(9)=option to integrate space charge forces over box
    ! if.eq.0. no integration.  see sub gaus for further
    ! explanation.
    ! *******************************************************************
    subroutine schfdyn
      implicit real *8(a-h, o-z)
      common /tapes/in, ifile, meta
      common /rcshef/sce(20)

      read (in, *) iread
      if (iread==0) then
        ! standard SCHEFF parameters
        sce(2) = 4.
        sce(3) = 4.
        sce(4) = 20
        sce(5) = 40
        sce(6) = 0
        sce(9) = 0.
        sce(7) = 0.
      else
        ! read  SCHEFF parameters
        read (in, *) sce(2), sce(3), sce(4), sce(5), sce(6), sce(7), sce(9)
      end if
      sce(3) = sce(3)*2.
      sce(8) = 0.
      call schefini
      return
    end subroutine schfdyn
    ! *******************************************************************
    ! SUBROUTINE intg3(npt)
    ! called by SCHERM
    ! Calculate the electric field components acting on each particle
    ! Gauss method
    ! *******************************************************************
    subroutine intg3(npt)
      implicit real *8(a-h, o-z)
      parameter(iptsz=100002, maxcell=3000, maxcell1=3000)
      common /consta/vl, pi, xmat, rpel, qst
      common /ttfc/tk, t1k, t2k, sk, s1k, s2k, fh
      common /hermt/afxt(22), afyt(22), afzt(22)
      common /hermd/afxm(20), afym(20), afzm(20)
      common /hermr/afxr(20), afyr(20), afzr(20)
      common /hermrr/afxrr(20), afyrr(20), afzrr(20)
      common /sizr/xrms3, yrms3, zrms3, zcgr3
      common /degherm/nmaz, nmazr, nmaxy
      common /sizt/xrms, yrms, zrms
      common /sizzt/xrmsz, yrmsz, zrmsz
      common /elcg/xcgd, ycgd, zcgd, xcgr, ycgr, zcgr
      common /intgrt/ex, ey, ez
      common /faisc/f(10, iptsz), imax, ngood
      common /sc3/beamc, scdist, sce10, cplm, ect, apl, ichaes, iscsp
      logical ichaes
      common /part/xc(iptsz), yc(iptsz), zc(iptsz)
      common /twcst/epsilon
      common /ecor/const
      common /cgrms/xsum, ysum, zsum
      common /npart/imaxr
      dimension ui(6), wi(6)
      data (ui(j), j=1, 6)/.033765, .169395, .380690, .619310, .830605, .966234/
      data (wi(j), j=1, 6)/.085662, .180381, .233957, .233957, .180381, .085662/

      ! Initialize some constants and variables
      ! freq. in MHz
      freq = fh*0.5e-06/pi
      xrmsc = xrmsz
      yrmsc = yrmsz
      zrmsc = zrmsz
      xgc = xsum
      ygc = ysum
      zgc = zsum
      qmpart = 1.0e-09*beamc/(float(ngood)*freq)
      ! omment        const=qmpart*xrmsc*yrmsc*zrmsc/(2.*epsilon)
      const = qmpart/(2.*epsilon)
      dnorm = (xrmsc*yrmsc*zrmsc)**.333333333
      dsq = dnorm*dnorm
      xsq = (xc(npt)-xgc)*(xc(npt)-xgc)
      ysq = (yc(npt)-ygc)*(yc(npt)-ygc)
      zsq = (zc(npt)-zgc)*(zc(npt)-zgc)
      ex = 0.
      ey = 0.
      ez = 0.
      ! initialize integrals to 0.
      ! integrate all 3 components (x,y,z)
      do j = 1, 6
        a1 = xrmsc*xrmsc - dsq + dsq/ui(j)
        a2 = yrmsc*yrmsc - dsq + dsq/ui(j)
        a3 = zrmsc*zrmsc - dsq + dsq/ui(j)
        t1 = xsq/a1
        t2 = ysq/a2
        t3 = zsq/a3
        txyz = sqrt(t1+t2+t3)
        if (abs(txyz)>13.) txyz = 13.
        ff1 = exp(-txyz*txyz/2.)*afzt(1)
        ff1 = ff1/(2.*pi)
        fxn = ff1/(ui(j)*ui(j)*sqrt(a1)*a1*sqrt(a2)*sqrt(a3))
        fyn = ff1/(ui(j)*ui(j)*sqrt(a1)*a2*sqrt(a2)*sqrt(a3))
        fzn = ff1/(ui(j)*ui(j)*sqrt(a1)*a3*sqrt(a2)*sqrt(a3))
        ex = ex + wi(j)*fxn*dsq
        ey = ey + wi(j)*fyn*dsq
        ez = ez + wi(j)*fzn*dsq
      end do
      ! Field components are in Newton/Coulomb
      ex = ex*const*(xc(npt)-xgc)
      ey = ey*const*(yc(npt)-ygc)
      ez = ez*const*(zc(npt)-zgc)
      return
    end subroutine intg3
    ! *******************************************************************
    ! SUBROUTINE compress(pib)
    ! PRINT OF PARTICLE COORDINATES
    ! *******************************************************************
    subroutine compress(pib)
      implicit real *8(a-h, o-z)
      parameter(iptsz=100002, maxcell=3000, maxcell1=3000)
      common /consta/vl, pi, xmat, rpel, qst
      common /faisc/f(10, iptsz), imax, ngood
      ! common/etcha1/dav2(maxcell1,33),ichas(iptsz),chasit
      ! common/sc3/beamc,scdist,sce10,cplm,ectt,apl,ichaes,iscsp
      common /ttfc/tk, t1k, t2k, sk, s1k, s2k, fh
      ! COMMON/DYN/TREF,VREF
      ! common/mcs/imcs,ncstat,cstat(20)
      ! common/tapes/in,ifile,meta
      ! common/etcha3/ichxyz(iptsz)
      ! common/rec/irec
      ! common/etcom/cog(8),exten(17),fd(iptsz)
      ! logical chasit
      ! Do so by shifting particles belonging to the same bunch outside the (+/-) pib window to
      ! inside the +/- pib window.
      pib = pib*pi/180
      do ite = 1, 3
        ! Find cog of bunch in time
        tcog = 0.
        do i = 1, ngood
          tcog = tcog + f(6, i)
        end do
        tcog = tcog/float(ngood)
        write (16, 58) tcog*fh*180./pi
58      format (' cog phase before shifting particles: ', e13.7, ' deg')
        do i = 1, ngood
          drad = (f(6,i)-tcog)*fh
          if (drad>pib) then
            f(6, i) = (f(6,i)-2.*pi/fh)
          end if
          if (drad<-pib) then
            f(6, i) = (f(6,i)+2.*pi/fh)
          end if
        end do
      end do
      ! Find cog of bunch in time after shifting particles
      do i = 1, ngood
        tcog = tcog + f(6, i)
      end do
      tcog = tcog/float(ngood)
      write (16, 59) tcog*fh*180./pi
59    format (' cog phase after shifting particles : ', e13.7, ' deg')
      return
    end subroutine compress
    ! *******************************************************************
    ! SUBROUTINE prbeam(iflg,wfile)
    ! PRINT OF PARTICLE COORDINATES
    ! *******************************************************************
    subroutine prbeam(iflg, wfile)
      implicit real *8(a-h, o-z)
      parameter(iptsz=100002, maxcell=3000, maxcell1=3000)
      common /consta/vl, pi, xmat, rpel, qst
      common /faisc/f(10, iptsz), imax, ngood
      common /etcha1/dav2(maxcell1, 33), ichas(iptsz), chasit
      common /sc3/beamc, scdist, sce10, cplm, ectt, apl, ichaes, iscsp
      common /ttfc/tk, t1k, t2k, sk, s1k, s2k, fh
      common /dyn/tref, vref
      common /mcs/imcs, ncstat, cstat(20)
      common /tapes/in, ifile, meta
      common /etcha3/ichxyz(iptsz)
      common /rec/irec
      common /etcom/cog(8), exten(17), fd(iptsz)
      logical chasit
      character *80 wfile
      ! PRINT OF PARTICLE COORDINATES
      ecog = 0.
      tcog = 0.
      xav = 0.
      xpav = 0.
      yav = 0.
      ypav = 0.
      ! **********************************************
      ! cog of the bunch
      do i = 1, ngood
        ecog = ecog + f(7, i)
        tcog = tcog + f(6, i)
        xav = xav + f(2, i)
        xpav = xpav + f(3, i)
        yav = yav + f(4, i)
        ypav = ypav + f(5, i)
      end do
      ecog = ecog/float(ngood)
      tcog = tcog/float(ngood)
      xav = xav/float(ngood)
      xpav = xpav/float(ngood)
      yav = yav/float(ngood)
      ypav = ypav/float(ngood)
      ! write particle coordinates to files,  phase in radian
      beref = vref/vl
      gamref = 1./sqrt(1.-(beref*beref))
      enref = xmat*gamref
      open (58, file=wfile, status='unknown')
      if (iflg<100) then
        write (58, *) ngood, beamc, fh/(2000000.*pi)
        if (chasit) then
          write (60, *) ngood, beamc, fh/(2000000.*pi)
          write (61, *) ngood, beamc, fh/(2000000.*pi)
        end if
      else
        write (58, *) ngood, beamc, fh/(2000000.*pi), enref - xmat
        if (chasit) then
          write (60, *) ngood, beamc, fh/(2000000.*pi), enref - xmat
          write (61, *) ngood, beamc, fh/(2000000.*pi), enref - xmat
        end if
      end if
      f2 = 0.
      f3 = 0.
      f4 = 0.
      f5 = 0.
      do i = 1, ngood
        if (irec==2) then
          ! coordinates relative to the reference
          eprt = f(7, i) - enref
          tprt = fh*(f(6,i)-tref)
          f2 = f(2, i)
          f3 = f(3, i)
          f4 = f(4, i)
          f5 = f(5, i)
        end if
        if (irec==1) then
          ! absolute values for phase and energy
          eprt = f(7, i) - xmat
          tprt = fh*(f(6,i)-tcog)
          ! **********************************
          f2 = f(2, i)
          f3 = f(3, i)
          f4 = f(4, i)
          f5 = f(5, i)
        end if
        if (irec==0) then
          ! values for phase and energy relative to the COG
          tprt = fh*(f(6,i)-tcog)
          eprt = f(7, i) - ecog
          f2 = f(2, i) - xav
          f3 = f(3, i) - xpav
          f4 = f(4, i) - yav
          f5 = f(5, i) - ypav
        end if
        if (iflg==0 .or. iflg==100) write (58, 100) f2, f3/1000., f4, f5/1000., tprt, eprt
        if (iflg==1 .or. iflg==101) write (58, 101) f2, f3/1000., f4, f5/1000., tprt, eprt, f(1, i)
        if (iflg==2 .or. iflg==102) write (58, 102) f2, f3/1000., f4, f5/1000., tprt, eprt, f(9, i)
        if (iflg==3 .or. iflg==103) write (58, 103) f2, f3/1000., f4, f5/1000., tprt, eprt, f(9, i), f(1, i)
        if (iflg==10 .or. iflg==110) write (58, 100) f2, f3/1000., f4, f5/1000., 1.e09*tprt/fh, eprt
        if (iflg==11 .or. iflg==111) write (58, 101) f2, f3/1000., f4, f5/1000., 1.e09*tprt/fh, eprt, f(1, i)
        if (iflg==12 .or. iflg==112) write (58, 102) f2, f3/1000., f4, f5/1000., 1.e09*tprt/fh, eprt, f(9, i)
        if (iflg==13 .or. iflg==113) write (58, 103) f2, f3/1000., f4, f5/1000., 1.e09*tprt/fh, eprt, f(9, i), f(1, i)
        ! ************** only with CHASE, write to file particles removed
        if (chasit) then
          if (ichxyz(i)==0) then
            if (iflg==0 .or. iflg==100) write (60, 100) f2, f3/1000., f4, f5/1000., tprt, eprt
            if (iflg==10 .or. iflg==110) write (60, 100) f2, f3/1000., f4, f5/1000., 1.e09*tprt/fh, eprt
            if (iflg==1 .or. iflg==101) write (60, 101) f2, f3/1000., f4, f5/1000., tprt, eprt, f(1, i)
            if (iflg==11 .or. iflg==111) write (60, 102) f2, f3/1000., f4, f5/1000., 1.e09*tprt/fh, eprt, f(1, i)
            if (iflg==2 .or. iflg==102) write (60, 101) f2, f3/1000., f4, f5/1000., tprt, eprt, f(9, i)
            if (iflg==12 .or. iflg==112) write (60, 102) f2, f3/1000., f4, f5/1000., 1.e09*tprt/fh, eprt, f(9, i)
          end if
          ! ************** only with CHASE, write to file particles kept
          if (ichxyz(i)==1) then
            if (iflg==0 .or. iflg==100) write (61, 100) f2, f3/1000., f4, f5/1000., tprt, eprt
            if (iflg==10 .or. iflg==110) write (61, 100) f2, f3/1000., f4, f5/1000., 1.e09*tprt/fh, eprt
            if (iflg==1 .or. iflg==101) write (61, 101) f2, f3/1000., f4, f5/1000., tprt, eprt, f(1, i)
            if (iflg==11 .or. iflg==111) write (61, 102) f2, f3/1000., f4, f5/1000., 1.e09*tprt/fh, eprt, f(1, i)
            if (iflg==2 .or. iflg==102) write (61, 101) f2, f3/1000., f4, f5/1000., tprt, eprt, f(9, i)
            if (iflg==12 .or. iflg==112) write (61, 102) f2, f3/1000., f4, f5/1000., 1.e09*tprt/fh, eprt, f(9, i)
          end if
        end if
      end do
      close (58)
100   format (6(e13.6,1x))
101   format (7(e13.6,1x))
102   format (7(e13.6,1x))
103   format (8(e13.6,1x))
      return
    end subroutine prbeam
    ! *******************************************************************
    ! SUBROUTINE gausse
    ! called by HERSC
    ! GAUSS method
    ! *******************************************************************
    subroutine gausse
      implicit real *8(a-h, o-z)
      common /gauss1/absg(40), wg(40), igaus
      common /randu/ck(15), kmax
      dimension ui(40), u9(9), u10(10), u12(12)
      dimension w9(9), w10(10), w12(12)
      ! GAUSS n=9 de -1. a 1
      data (u9(j), j=1, 9)/ -.9681602, -.8360311, -.6133714, -.3242534, 0., .3242534, .6133714, .8360311, .9681602/
      data (w9(j), j=1, 9)/.0812744, .1806482, .2606107, .3123471, .3302394, .3123471, .2606107, .1806482, .0812744/
      ! GAUSS n=10 de -1. a 1
      data (u10(j), j=1, 10)/ -.9739065, -.8650634, -.6794096, -.4333954, -.1488743, .1488743, .4333954, .6794096, &
        .8650634, .9739065/
      data (w10(j), j=1, 10)/.0666713, .1494513, .2190864, .2692667, .2955242, .2955242, .2692667, .2190864, .1494513, &
        .0666713/
      ! GAUSS n=12 de -1. a 1
      data (u12(j), j=1, 12)/ -.9815606, -.9041173, -.7699027, -.5873180, -.3678315, -.1252334, .1252334, .3678315, &
        .5873180, .7699027, .9041173, .9815606/
      data (w12(j), j=1, 12)/.0471753, .1069393, .1600783, .2031674, .2334925, .2491470, .2491470, .2334925, .2031674, &
        .1600783, .1069393, .0471753/
      ! built the abscissas from (-1,1) to (1,0)
      if (igaus==9) then
        do i = 1, igaus
          ui(i) = u9(i)
          wg(i) = w9(i)
        end do
      end if
      ! following options in case one wishes to use 10 or 12 steps
      if (igaus==10) then
        do i = 1, igaus
          ui(i) = u10(i)
          wg(i) = w10(i)
        end do
      end if
      if (igaus==12) then
        do i = 1, igaus
          ui(i) = u12(i)
          wg(i) = w12(i)
        end do
      end if
      do i = 1, igaus
        absg(i) = (1.+ui(i))/2.
        wg(i) = wg(i)/2.
      end do
      return
    end subroutine gausse
    ! *******************************************************************
    ! SUBROUTINE table(lbmax,mbmax,nbmax)
    ! called by HERSC
    ! arrays of variables independent of the coordinates of particles
    ! lbmax,mbmax,nbmax are the maximum degrees of the
    ! coefficients A(l,m,n)
    ! *******************************************************************
    subroutine table(lbmax, mbmax, nbmax)
      implicit real *8(a-h, o-z)
      common /gauss1/absg(40), wg(40), igaus
      common /circu/co(40, 50), sn(40, 50), blam(40, 100)
      common /expmod/ragp(40, 100), ragm1(40, 40)
      common /randu/ck(15), kmax
      common /hass/carg(100), sarg(100), argip(100)
      common /const/pi2, sqpi, pwtpi, sqpi2, sq2pi
      common /consta/vl, pi, xmat, rpel, qst
      common /factor/fpir(40, 40), fect(30)
      ! maximum of subscripts : ideg
      ! igaus: order of the Gauss integration ******
      ! maximum of lbmax,mmax,nbmax -->ideg
      ideg = nbmax
      if (lbmax>=ideg) ideg = lbmax
      if (mbmax>=ideg) ideg = mbmax
      ideg = ideg + 1
      idegp2 = ideg + 2
      ! arrays of the power of the circular functions fo the Gauss positions absg(i)
      ! the maximum power is ideg+2
      do i = 1, igaus
        co(i, 1) = 1.
        sn(i, 1) = 1.
      end do
      do i = 1, igaus
        aco = pi*absg(i)/2.
        cod = cos(aco)
        snd = sin(aco)
        do j = 2, idegp2
          co(i, j) = co(i, j-1)*cod
          sn(i, j) = sn(i, j-1)*snd
        end do
      end do
      ! arrays used in the integrals of tables 75 and 76
      ! absg(i)**2(t1+t2+t3+1)+1-->ragp(i,j) i: Gauss positions, j: is the power
      idgp = 3*ideg + kmax
      kemax = kmax/2
      do i = 1, igaus
        ragp(i, 1) = 1.
        ragm1(i, 1) = 1.
        absm2 = (1.-absg(i))*(1.-absg(i))
        do j = 2, idgp
          ragp(i, j) = ragp(i, j-1)*absg(i)
        end do
        ! storage of (absg(i)-1)**2*kemax -->ragm1
        do j = 2, kemax + 1
          ragm1(i, j) = ragm1(i, j-1)*absm2
        end do
      end do
      do i = 1, idgp + 1
        carg(i) = sqrt((4.*float(i-1)+1.)/2.)
        sarg(i) = sqrt((4.*float(i-1)+3.)/2.)
        argip(i) = sqrt(2.*float(i-1)+1.)
      end do
      ! store the factorials
      do i = 1, 40
        do j = 1, i
          fpir(i, j) = fper(i-1, j-1)
        end do
      end do
      fj = 1.
      fect(1) = 1.
      do i = 1, 23
        fi = float(i)
        fj = fj*fi
        fect(i+1) = fj
      end do
      return
    end subroutine table
    ! *******************************************************************
    ! FUNCTION fpar(i,j)
    ! Factorial function called by HERSC
    ! *******************************************************************
    function fpar(i, j)
      implicit real *8(a-h, o-z)
      common /factor/fpir(40, 40), fect(30)

      ii = i + 1
      jj = j + 1
      fpar = fpir(ii, jj)
      return
    end function fpar
    ! *******************************************************************
    ! FUNCTION fper(i,j)
    ! called by HERSC
    ! i*(i-1)*(i-2)*...(i-j+1)/(1.2....j)
    ! *******************************************************************
    function fper(i, j)
      implicit real *8(a-h, o-z)

      faci = 1.
      facj = 1.
      fper = 1.
      if (i==0) return
      if (j==0) return
      do k = 1, j
        facj = facj*float(k)
      end do
      ii = i
      do k = 1, j
        faci = faci*float(ii)
        ii = ii - 1
      end do
      fper = faci/facj
      return
    end function fper
    ! *******************************************************************
    ! FUNCTION hermint(s,ihd)
    ! called by HERSC
    ! *******************************************************************
    function hermint(s, ihd)
      implicit real *8(a-h, o-z)
      dimension he(100)

      hermint = 0.
      if (ihd==0) then
        hermint = 1.
        return
      end if
      if (ihd==1) then
        hermint = s
        return
      end if
      he(1) = 1.
      he(2) = s
      m1 = ihd - 1
      do k = 1, m1
        he(k+2) = s*he(k+1) - float(k)*he(k)
      end do
      hermint = he(ihd+1)*exp(-s*s/2.)
      return
    end function hermint
    ! *******************************************************************
    ! FUNCTION fact(m)
    ! FACTORIAL of M
    ! *******************************************************************
    function fact(m)
      implicit real *8(a-h, o-z)

      fact = 1.
      if (m==0) return
      do k = 1, m
        fact = fact*float(k)
      end do
      return
    end function fact
    ! *******************************************************************
    ! FUNCTION factd(m)
    ! Calculate of (-1)**m *(2m-1)!!
    ! *******************************************************************
    function factd(m)
      implicit real *8(a-h, o-z)
      dimension he(100)

      factd = 1.
      if (m==0) factd = 1.
      if (m==1) then
        factd = -1.
        return
      end if
      he(1) = 1.
      do k = 1, 2*m - 1, 2
        he(k+2) = -float(k)*he(k)
      end do
      factd = he(2*m+1)
      continue
      return
    end function factd
    ! *******************************************************************
    ! SUBROUTINE bhdist
    ! called by HERSC
    ! computes: the coefficients A(l,m,n)
    ! the rms sizes in x, y and z-direction
    ! selects:  the significants terms in the Hermite series expansion
    ! lmax, mmax and nmax are the maximum values of l, m, n for these
    ! coefficients
    ! *******************************************************************
    subroutine bhdist
      implicit real *8(a-h, o-z)
      common /coef/a(30, 30, 30), xa, xb, xc
      common /ind/lmax, mmax, nmax
      common /indin/lmaxi, mmaxi, nmaxxi
      common /hcgrms/xcdg, ycdg, zcdg, ect, eps
      ! character iitime*30
      ! hermite degrees
      lmax = lmaxi
      mmax = mmaxi
      nmax = nmaxxi
      ect = 4.
      ! call mytime(iitime)
      ! write(16,*) 'PINTFAST started at ',iitime
      call pintfast
      ! call mytime(iitime)
      ! write(16,*) 'PINTFAST end, HCOEF started at ',iitime
      call hcoef
      ! call mytime(iitime)
      ! write(16,*) 'HCOEF ended at ',iitime
      return
    end subroutine bhdist
    ! *******************************************************************
    ! SUBROUTINE trms(isucc)
    ! called by HERSC
    ! storage  of the variables depending only of the rms sizes
    ! lmax,mmax,nmax : maximum of the subscripts: l,m,n
    ! for the significants Almn
    ! isucc:order of succession of the integrals in table 1-b
    ! isucc=1: order of succesion x-->y-->z
    ! isucc=2: order of succesion y-->z-->x
    ! isucc=3: order of succesion z-->x-->y
    ! *******************************************************************
    subroutine trms(isucc)
      implicit real *8(a-h, o-z)
      common /consta/vl, pi, xmat, rpel, qst
      common /coef/a(30, 30, 30), xa, xb, xc
      common /ind/lmax, mmax, nmax
      ! lmax,mmax,nmax from zero
      common /rms/rms(3, 50), s1, s2, s3
      common /gauss1/absg(40), wg(40), igaus
      common /circu/co(40, 50), sn(40, 50), blam(40, 100)
      common /randu/ck(15), kmax
      ! minimum of the rms sizes xa,xb,xc
      rmin = xa
      if (rmin>xb) rmin = xb
      if (rmin>xc) rmin = xc
      ! order of the succession of the integrals
      if (rmin==xc) isucc = 3
      if (rmin==xb) isucc = 2
      if (rmin==xa) isucc = 1
      ! maximum of lmax,mmax,nmax
      maxi = lmax
      if (maxi<mmax) maxi = mmax
      if (maxi<nmax) maxi = nmax
      maxt = 2*(maxi+1) + 3
      x3 = 0.
      x2 = 0.
      x1 = 0.
      ! order of succession x->y->z
      if (isucc==1) then
        x3 = xa
        x2 = xb
        x1 = xc
      end if
      ! order of succession y->z->x
      if (isucc==2) then
        x3 = xb
        x2 = xc
        x1 = xa
      end if
      ! order of succession z->x->y
      if (isucc==3) then
        x3 = xc
        x2 = xa
        x1 = xb
      end if
      ! array rms(j,i) Powers of the rms sizes  j=1,2,3, the value i is the power
      rms(3, 1) = 1.
      rms(2, 1) = 1.
      rms(1, 1) = 1.
      do i = 2, maxt
        rms(3, i) = rms(3, i-1)*x3
        rms(2, i) = rms(2, i-1)*x2
        rms(1, i) = rms(1, i-1)*x1
      end do
      j1 = kmax/2
      i1m = (lmax+1)/2
      i2m = (mmax+1)/2
      i3m = (nmax+1)/2
      im = i1m + i2m + i3m + j1 + 4
      if (im>=40) then
        write (16, *) ' overlap the array blam with im= ', im
        stop
      end if
      do i = 1, igaus
        blam(i, 1) = (rms(1,3)*co(i,3)+rms(2,3)*sn(i,3))/rms(3, 3)
        do ii = 2, im
          blam(i, ii) = blam(i, ii-1)*blam(i, 1)
        end do
      end do
      return
    end subroutine trms
    ! *******************************************************************
    ! SUBROUTINE uvrms
    ! called by HERSC
    ! storage of the variables depending only of the coordinate s3
    ! *******************************************************************
    subroutine uvrms
      implicit real *8(a-h, o-z)
      common /consta/vl, pi, xmat, rpel, qst
      common /rms/rms(3, 50), s1, s2, s3
      common /gauss1/absg(40), wg(40), igaus
      common /circu/co(40, 50), sn(40, 50), blam(40, 100)
      common /uvtab/epsi1(40, 40), epsi2(40, 40), akpcc(40, 40), akpcs(40, 40), akpsc(40, 40), akpss(40, 40)
      common /expmod/ragp(40, 100), ragm1(40, 40)
      common /cars3/exs3, exs2, exs1, as3, sgns3, s32, pwas3, pw3as3
      common /ind/lmax, mmax, nmax
      common /indttal/lmnt
      common /randu/ck(15), kmax
      common /const/pi2, sqpi, pwtpi, sqpi2, sq2pi
      ! pi2=pi*pi, sqpi=(pi/2)**3/2
      common /comtab/hsint(40, 2, 60), sqblam(40), s3pw(15)
      common /herfun/hs1(60), hs2(60), hs3(60)

      s32 = s3*s3
      s22 = s2*s2
      s12 = s1*s1
      exs3 = exp(-s32/2.)
      exs2 = exp(-s22/2.)
      exs1 = exp(-s12/2.)
      as3 = abs(s3)
      sgns3 = 1.
      if (s3<0.) sgns3 = -1.
      as31 = as3*s1
      as32 = as3*s2
      s1rms = s1*rms(1, 2)
      s2rms = s2*rms(2, 2)
      ! power of as3, used in the functions spii,......
      s3pw(1) = 1.
      do i = 2, kmax
        s3pw(i) = s3pw(i-1)*as3
      end do
      ! memory array hsint(ig,arg,indice) for functions sipp,...
      do ig = 1, igaus
        wgpi = wg(ig)*pi/2.
        sqblam(ig) = sqrt(blam(ig,1))
        xlblam = sqblam(ig)*rms(3, 2)
        do iarg = 1, 2
          arghm1 = s1rms*co(ig, 2)/xlblam
          arghm2 = s2rms*sn(ig, 2)/xlblam
          if (iarg==1) then
            arg = arghm1 + arghm2
            earg = exp(-arg*arg/2.)
          end if
          if (iarg==2) then
            arg = arghm1 - arghm2
            earg = exp(-arg*arg/2.)
          end if
          hsint(ig, iarg, 1) = 1.*earg*wgpi
          hsint(ig, iarg, 2) = arg*earg*wgpi
          do inhs = 3, lmnt
            hsint(ig, iarg, inhs) = arg*hsint(ig, iarg, inhs-1) - float(inhs-2)*hsint(ig, iarg, inhs-2)
          end do
        end do
      end do
      r13 = rms(1, 2)/rms(3, 2)
      r23 = rms(2, 2)/rms(3, 2)
      do j = 1, igaus
        do i = 1, igaus
          aeps1 = ragp(i, 3)*(blam(j,1)-1.)/2.
          aeps1 = s32*(aeps1+ragp(i,2))
          aeps2 = ragp(i, 3)*blam(j, 1)/2.
          aeps2 = aeps2*s32
          akc1 = ragp(i, 2)*r13*co(j, 2)*as31
          akc2 = ragp(i, 2)*r23*sn(j, 2)*as32
          aks1 = ragp(i, 2)*r13*co(j, 2)*as31
          aks2 = ragp(i, 2)*r23*sn(j, 2)*as32
          epsi1(i, j) = exp(-aeps1)*wg(i)
          epsi2(i, j) = exp(-aeps2)*wg(i)
          akpcc(i, j) = cos(akc1)*cos(akc2)
          akpcs(i, j) = cos(akc1)*sin(akc2)
          akpsc(i, j) = sin(akc1)*cos(akc2)
          akpss(i, j) = sin(akc1)*sin(akc2)
        end do
      end do
      ! Hermite functions
      hs1(1) = exs1
      hs2(1) = exs2
      hs3(1) = exs3
      hs1(2) = s1*exs1
      hs2(2) = s2*exs2
      hs3(2) = s3*exs3
      do ihe = 3, lmnt
        hs1(ihe) = s1*hs1(ihe-1) - float(ihe-2)*hs1(ihe-2)
        hs2(ihe) = s2*hs2(ihe-1) - float(ihe-2)*hs2(ihe-2)
        hs3(ihe) = s3*hs3(ihe-1) - float(ihe-2)*hs3(ihe-2)
      end do
      return
    end subroutine uvrms
    ! *******************************************************************
    ! SUBROUTINE fielde(lc,mc,nc,isucc)
    ! beam self-fields computation called by HERSC
    ! look for the parity of the currents lc,mc and nc
    ! compute the corresponding field components
    ! isucc=1: a<b,c
    ! isucc=2: b<a,c
    ! isucc=3: c<a,b
    ! x,y,z are the scaling coordinates: x/a,y/b,z/c
    ! The corresponding analytical equations are in the number of the
    ! tables. The table number in 'comments' refers to the corresponding
    ! analytical equations
    ! *******************************************************************
    subroutine fielde(lc, mc, nc, isucc)
      implicit real *8(a-h, o-z)
      common /rms/rms(3, 50), s1, s2, s3
      common /partcl/x, y, z
      common /const/pi2, sqpi, pwtpi, sqpi2, sq2pi
      common /field/ex, ey, ez
      common /randu/ck(15), kmax
      ! pi2=pi*pi, sqpi=(pi/2)**3/2
      common /cars3/exs3, exs2, exs1, as3, sgns3, s32, pwas3, pw3as3
      ! exs3=exp(-s3*s3/2),abs3=abs(s3),sgns3=sign s3,s32=s3*s3
      ! pwas3=as3**(2(it1+it2+it3)+1),pw3as3=as3**(2*it3))
      common /sgpth/mksgi, mksgp
      common /ftth/makti, maktp
      common /fsth/maksi, maksp
      logical maksi, maksp
      logical makti, maktp
      logical mksgi, mksgp
      logical lpl, lpm, lpn
      ! look for the parity of the currents lc,mc,nc
      lpl = .false.
      lpm = .false.
      lpn = .false.
      makti = .false.
      maktp = .false.
      maksi = .false.
      maksp = .false.
      mksgi = .false.
      mksgp = .false.
      xlc = lc
      tl = xlc - 2.*int(xlc/2.+0.0001)
      if (tl==0.) lpl = .true.
      xmc = mc
      tm = xmc - 2.*int(xmc/2.+0.0001)
      if (tm==0.) lpm = .true.
      xnc = nc
      tn = xnc - 2.*int(xnc/2.+0.0001)
      if (tn==0.) lpn = .true.
      if (lpl .and. lpm .and. lpn) itpar = 1
      if (lpl .and. lpm .and. .not. lpn) itpar = 2
      if (lpl .and. .not. lpm .and. lpn) itpar = 3
      if (lpl .and. .not. lpm .and. .not. lpn) itpar = 4
      if (.not. lpl .and. lpm .and. lpn) itpar = 5
      if (.not. lpl .and. lpm .and. .not. lpn) itpar = 6
      if (.not. lpl .and. .not. lpm .and. lpn) itpar = 7
      if (.not. lpl .and. .not. lpm .and. .not. lpn) itpar = 8

      ! values of the variables it1,it2,it3 in relation with lc,mc,nc
      ! the initial values of these lc,mc,nc is zero
      if (isucc==1) then
        ! a<b,c
        if (itpar==1) then
          ! E E E and  a<b,c:
          ! table 67-a: Ex=E(2t3+1,2t2,2t1)
          ! Ey=E(2t3,2t2+1,2t1)
          ! Ez=E(2t3,2t2,2t1+1)
          ! values of it1,it2,it3 in table 3-a
          it3 = lc/2
          it2 = mc/2
          it1 = nc/2
          if (s3/=0.) then
            ! it=2*(it1+it2+it3)+1
            it = lc + mc + nc + 1
            pwas3 = as3**it
          end if
          ex = eipp(it1, it2, it3)
          ey = epip(it1, it2, it3)
          ez = eppi(it1, it2, it3)
          return
        end if
        if (itpar==2) then
          ! E E I and  a<b,c
          ! table 67-g: Ex=E(2t3+1,2t2,2t1+1)
          ! Ey=E(2t3,2t2+1,2t1+1)
          ! Ez=E(2t3,2t2,2t1)
          ! values of it1,it2,it3 in table 3-g
          ! x-direction and y-direction
          it3 = lc/2
          it2 = mc/2
          it1 = (nc-1)/2
          if (s3/=0.) then
            ! it=2*(it1+it2+it3)+1
            it = lc + mc + nc
            pwas3 = as3**it
          end if
          ex = eipi(it1, it2, it3)
          ey = epii(it1, it2, it3)
          ! z-direction
          it1 = (nc+1)/2
          if (s3/=0.) pwas3 = pwas3*s32
          ! it=2*(it1+it2+it3)+1
          ez = eppp(it1, it2, it3)
          return
        end if
        if (itpar==3) then
          ! E I E and  a<b,c
          ! in table 67-h: Ex=E(2t3+1,2t2+1,2t1)
          ! Ey=E(2t3,2t2,2t1)
          ! Ez=E(2t3,2t2+1,2t1+1)
          ! values of it1,it2,it3 in table 3-h
          ! x-direction
          it3 = lc/2
          it2 = (mc-1)/2
          it1 = nc/2
          if (s3/=0.) then
            ! it=2*(it1+it2+it3)+1
            it = lc + mc + nc
            apwas3 = as3**it
            pwas3 = apwas3
          end if
          ex = eiip(it1, it2, it3)
          ! y-direction
          it3 = lc/2
          it2 = (mc+1)/2
          it1 = nc/2
          ! it=2*(it1+it2+it3)+1
          if (s3/=0.) pwas3 = pwas3*s32
          ey = eppp(it1, it2, it3)
          ! z-direction
          it3 = lc/2
          it2 = (mc-1)/2
          it1 = nc/2
          if (s3/=0.) pwas3 = apwas3
          ! it=2*(it1+it2+it3)+1
          ez = epii(it1, it2, it3)
          return
        end if
        if (itpar==4) then
          ! E I I and  a<b,c
          ! in table 67-f: Ex=E(2t3+1,2t2+1,2t1+1)
          ! Ey=E(2t3,2t2,2t1+1)
          ! Ez=E(2t3,2t2+1,2t1)
          ! values of it1,it2,it3 in table 3-f
          ! x-direction
          it3 = lc/2
          it2 = (mc-1)/2
          it1 = (nc-1)/2
          if (s3/=0.) then
            ! it=2*(it1+it2+it3)+1
            it = lc + mc + nc - 1
            pwas3 = as3**it
          end if
          ex = eiii(it1, it2, it3)
          ! y-direction
          it3 = lc/2
          it2 = (mc+1)/2
          it1 = (nc-1)/2
          ! it=2*(it1+it2+it3)+1
          if (s3/=0.) pwas3 = pwas3*s32
          ey = eppi(it1, it2, it3)
          ! z-direction
          it3 = lc/2
          it2 = (mc-1)/2
          it1 = (nc+1)/2
          ez = epip(it1, it2, it3)
          return
        end if
        if (itpar==5) then
          ! I E E and  a<b,c
          ! in table 67-c: Ex=E(2t3,2t2,2t1)
          ! Ey=E(2t3+1,2t2+1,2t1)
          ! Ez=E(2t3+1,2t2,2t1+1)
          ! values of it1,it2,it3 in table 3-c
          ! x-direction
          it3 = (lc+1)/2
          it2 = mc/2
          it1 = nc/2
          if (s3/=0.) then
            ! it=2*(it1+it2+it3)+1
            it = lc + mc + nc
            apwas3 = as3**it
            pwas3 = apwas3*s32
          end if
          ex = eppp(it1, it2, it3)
          ! y-direction
          it3 = (lc-1)/2
          it2 = mc/2
          it1 = nc/2
          if (s3/=0.) then
            ! it=2*(it1+it2+it3)+1
            pwas3 = apwas3
            pw3as3 = apwas3
          end if
          ey = eiip(it1, it2, it3)
          ! z-direction
          it3 = (lc-1)/2
          it2 = mc/2
          it1 = nc/2
          ez = eipi(it1, it2, it3)
          return
        end if
        if (itpar==6) then
          ! I E I and  a<b,c
          ! in table 67-e: Ex=E(2t3,2t2,2t1+1)
          ! Ey=E(2t3+1,2t2+1,2t1+1)
          ! Ez=E(2t3+1,2t2,2t1)
          ! values of it1,it2,it3 in table 3-e
          ! x-direction
          it3 = (lc+1)/2
          it2 = mc/2
          it1 = (nc-1)/2
          if (s3/=0.) then
            ! it=2*(it1+it2+it3)+1
            it = lc + mc + nc - 1
            apwas3 = as3**it
            pwas3 = apwas3*s32
          end if
          ex = eppi(it1, it2, it3)
          ! y-direction
          it3 = (lc-1)/2
          it2 = mc/2
          it1 = (nc-1)/2
          if (s3/=0.) then
            ! it=2*(it1+it2+it3)+1
            pwas3 = apwas3
          end if
          ey = eiii(it1, it2, it3)
          ! z-direction
          it3 = (lc-1)/2
          it2 = mc/2
          it1 = (nc+1)/2
          ! it=2*(it1+it2+it3)+1
          if (s3/=0.) pwas3 = pwas3*s32
          ez = eipp(it1, it2, it3)
          return
        end if
        if (itpar==7) then
          ! I I E and  a<b,c
          ! in table 67-d: Ex=E(2t3,2t2+1,2t1)
          ! Ey=E(2t3+1,2t2,2t1)
          ! Ez=E(2t3+1,2t2+1,2t1+1)
          ! values of it1,it2,it3 in table 3-d
          ! x-direction
          it3 = (lc+1)/2
          it2 = (mc-1)/2
          it1 = nc/2
          if (s3/=0.) then
            ! it=2*(it1+it2+it3)+1
            it = lc + mc + nc - 1
            apwas3 = as3**it
            pwas3 = apwas3*s32
          end if
          ex = epip(it1, it2, it3)
          ! y-direction
          it3 = (lc-1)/2
          it2 = (mc+1)/2
          it1 = nc/2
          ! it=2*(it1+it2+it3)+1
          ey = eipp(it1, it2, it3)
          ! z-direction
          it3 = (lc-1)/2
          it2 = (mc-1)/2
          it1 = nc/2
          ! it=2*(it1+it2+it3)+1
          if (s3/=0.) pwas3 = apwas3
          ez = eiii(it1, it2, it3)
          return
        end if
        if (itpar==8) then
          ! I I I and  a<b,c
          ! in table 67-b: Ex=E(2t3,2t2+1,2t1+1)
          ! Ey=E(2t3+1,2t2,2t1+1)
          ! Ez=E(2t3+1,2t2+1,2t1)
          ! values of it1,it2,it3 in table 3-b
          ! x-direction
          it3 = (lc+1)/2
          it2 = (mc-1)/2
          it1 = (nc-1)/2
          if (s3/=0.) then
            ! it=2*(it1+it2+it3)+1
            it = lc + mc + nc
            pwas3 = as3**it
          end if
          ex = epii(it1, it2, it3)
          ! y-direction
          it3 = (lc-1)/2
          it2 = (mc+1)/2
          it1 = (nc-1)/2
          ! it=2*(it1+it2+it3)+1
          ey = eipi(it1, it2, it3)
          ! z-direction
          it3 = (lc-1)/2
          it2 = (mc-1)/2
          it1 = (nc+1)/2
          ez = eiip(it1, it2, it3)
          return
        end if
        ! endif of isucc=1----> a<b,c
      end if
      if (isucc==2) then
        ! b<a,c
        if (itpar==1) then
          ! E E E and  b<a,c
          ! table 67-a: Ex=E(2t3,2t2,2t1+1)
          ! Ey=E(2t3+1,2t2,2t1)
          ! Ez=E(2t3,2t2+1,2t1)
          ! values of it1,it2,it3 in table 3-a
          it3 = mc/2
          it2 = nc/2
          it1 = lc/2
          if (s3/=0.) then
            ! it=2*(it1+it2+it3)+1
            it = mc + nc + lc + 1
            pwas3 = as3**it
          end if
          ex = eppi(it1, it2, it3)
          ey = eipp(it1, it2, it3)
          ez = epip(it1, it2, it3)
          return
        end if
        if (itpar==2) then
          ! E E I and  b<a,c
          ! table 67-h: Ex=E(2t3,2t2+1,2t1+1)
          ! Ey=E(2t3+1,2t2+1,2t1)
          ! Ez=E(2t3,2t2,2t1)
          ! values of it1,it2,it3 in table 3-h
          ! x-direction and y-direction
          it3 = mc/2
          it2 = (nc-1)/2
          it1 = lc/2
          if (s3/=0) then
            ! it=2*(it1+it2+it3)+1
            it = mc + nc + lc
            pwas3 = as3**it
          end if
          ex = epii(it1, it2, it3)
          ey = eiip(it1, it2, it3)
          ! z-direction
          it2 = (nc+1)/2
          ! it=2*(it1+it2+it3)+1
          if (s3/=0.) pwas3 = pwas3*s32
          ez = eppp(it1, it2, it3)
          return
        end if
        if (itpar==3) then
          ! E I E and  b<a,c
          ! in table 67-c: Ex=E(2t3+1,2t2,2t1+1)
          ! Ey=E(2t3,2t2,2t1)
          ! Ez=E(2t3+1,2t2+1,2t1)
          ! values of it1,it2,it3 in table 3-c
          ! x-direction
          it3 = (mc-1)/2
          it2 = nc/2
          it1 = lc/2
          if (s3/=0.) then
            ! it=2*(it1+it2+it3)+1
            it = mc + nc + lc
            apwas3 = as3**it
            pwas3 = apwas3
          end if
          ex = eipi(it1, it2, it3)
          ! y-direction
          it3 = (mc+1)/2
          it2 = nc/2
          it1 = lc/2
          if (s3/=0.) then
            ! it=2*(it1+it2+it3)+1
            pwas3 = pwas3*s32
          end if
          ey = eppp(it1, it2, it3)
          ! z-direction
          it3 = (mc-1)/2
          it2 = nc/2
          it1 = lc/2
          if (s3/=0.) pwas3 = apwas3
          ez = eiip(it1, it2, it3)
          return
        end if
        if (itpar==4) then
          ! E I I and  b<a,c
          ! in table 67-d: Ex=E(2t3+1,2t2+1,2t1+1)
          ! Ey=E(2t3,2t2+1,2t1)
          ! Ez=E(2t3+1,2t2,2t1)
          ! values of it1,it2,it3 in table 3-d
          ! x-direction
          it3 = (mc-1)/2
          it2 = (nc-1)/2
          it1 = lc/2
          if (s3/=0.) then
            ! it=2*(it1+it2+it3)+1
            it = mc + nc + lc - 1
            pwas3 = as3**it
          end if
          ex = eiii(it1, it2, it3)
          ! y-direction
          it3 = (mc+1)/2
          it2 = (nc-1)/2
          it1 = lc/2
          ! it=2*(it1+it2+it3)+1
          if (s3/=0.) then
            pwas3 = pwas3*s32
          end if
          ey = epip(it1, it2, it3)
          ! z-direction
          it3 = (mc-1)/2
          it2 = (nc+1)/2
          it1 = lc/2
          ! it=2*(it1+it2+it3)+1
          ez = eipp(it1, it2, it3)
          return
        end if
        if (itpar==5) then
          ! I E E and  b<a,c
          ! in table 67-g: Ex=E(2t3,2t2,2t1)
          ! Ey=E(2t3+1,2t2,2t1+1)
          ! Ez=E(2t3,2t2+1,2t1+1)
          ! values of it1,it2,it3 in table 3-g
          ! x-direction
          it3 = mc/2
          it2 = nc/2
          it1 = (lc+1)/2
          if (s3/=0.) then
            ! it=2*(it1+it2+it3)+1
            it = mc + nc + lc
            apwas3 = as3**it
            pwas3 = apwas3*s32
          end if
          ex = eppp(it1, it2, it3)
          ! y-direction
          it3 = mc/2
          it2 = nc/2
          it1 = (lc-1)/2
          ! it=2*(it1+it2+it3)+1
          if (s3/=0.) pwas3 = apwas3
          ey = eipi(it1, it2, it3)
          ! z-direction
          it3 = mc/2
          it2 = nc/2
          it1 = (lc-1)/2
          ez = epii(it1, it2, it3)
          return
        end if
        if (itpar==6) then
          ! I E I and  b<a,c
          ! in table 67-f: Ex=E(2t3,2t2+1,2t1)
          ! Ey=E(2t3+1,2t2+1,2t1+1)
          ! Ez=E(2t3,2t2,2t1+1)
          ! values of it1,it2,it3 in table 3-f
          ! x-direction
          it3 = mc/2
          it2 = (nc-1)/2
          it1 = (lc+1)/2
          if (s3/=0.) then
            ! it=2*(it1+it2+it3)+1
            it = mc + nc + lc - 1
            apwas3 = as3**it
            pwas3 = apwas3*s32
          end if
          ex = epip(it1, it2, it3)
          ! y-direction
          it3 = mc/2
          it2 = (nc-1)/2
          it1 = (lc-1)/2
          ! it=2*(it1+it2+it3)+1
          if (s3/=0.) pwas3 = apwas3
          ey = eiii(it1, it2, it3)
          ! z-direction
          it3 = mc/2
          it2 = (nc+1)/2
          it1 = (lc-1)/2
          ! it=2*(it1+it2+it3)+1
          if (s3/=0.) pwas3 = apwas3*s32
          ez = eppi(it1, it2, it3)
          return
        end if
        if (itpar==7) then
          ! I I E and  b<a,c
          ! in table 66-e: Ex=E(2t3+1,2t2,2t1)
          ! Ey=E(2t3,2t2,2t1+1)
          ! Ez=E(2t3+1,2t2+1,2t1+1)
          ! values of it1,it2,it3 in table 3-e
          ! x-direction
          it3 = (mc-1)/2
          it2 = nc/2
          it1 = (lc+1)/2
          if (s3/=0.) then
            ! it=2*(it1+it2+it3)+1
            it = mc + nc + lc - 1
            apwas3 = as3**it
            pwas3 = apwas3*s32
          end if
          ex = eipp(it1, it2, it3)
          ! y-direction
          it3 = (mc+1)/2
          it2 = nc/2
          it1 = (lc-1)/2
          ! it=2*(it1+it2+it3)+1
          ey = eppi(it1, it2, it3)
          ! z-direction
          it3 = (mc-1)/2
          it2 = nc/2
          it1 = (lc-1)/2
          if (s3/=0.) pwas3 = apwas3
          ! it=2*(it1+it2+it3)+1
          ez = eiii(it1, it2, it3)
          return
        end if
        if (itpar==8) then
          ! I I I and  b<a,c
          ! in table 67-b: Ex=E(2t3+1,2t2+1,2t1)
          ! Ey=E(2t3,2t2+1,2t1+1)
          ! Ez=E(2t3+1,2t2,2t1+1)
          ! values of it1,it2,it3 in table 3-b
          ! x-direction
          it3 = (mc-1)/2
          it2 = (nc-1)/2
          it1 = (lc+1)/2
          if (s3/=0.) then
            ! it=2*(it1+it2+it3)+1
            it = mc + nc + lc
            pwas3 = as3**it
          end if
          ex = eiip(it1, it2, it3)
          ! y-direction
          it3 = (mc+1)/2
          it2 = (nc-1)/2
          it1 = (lc-1)/2
          ! it=2*(it1+it2+it3)+1
          ey = epii(it1, it2, it3)
          ! z-direction
          it3 = (mc-1)/2
          it2 = (nc+1)/2
          it1 = (lc-1)/2
          ! it=2*(it1+it2+it3)+1
          ez = eipi(it1, it2, it3)
          return
        end if
        ! endif of isucc=2----> b<a,c
      end if
      if (isucc==3) then
        ! c<a,b
        if (itpar==1) then
          ! E E E and  c<a,b
          ! table 67-a: Ex=E(2t3,2t2+1,2t1)
          ! Ey=E(2t3,2t2,2t1+1)
          ! Ez=E(2t3+1,2t2,2t1)
          ! values of it1,it2,it3 in table 3-a
          it3 = nc/2
          it2 = lc/2
          it1 = mc/2
          if (s3/=0.) then
            ! it=2*(it1+it2+it3)+1
            it = nc + lc + mc + 1
            pwas3 = as3**it
          end if
          ex = epip(it1, it2, it3)
          ey = eppi(it1, it2, it3)
          ez = eipp(it1, it2, it3)
          return
        end if
        if (itpar==2) then
          ! E E I and  c<a,b
          ! table 67-c: Ex=E(2t3+1,2t2+1,2t1)
          ! Ey=E(2t3+1,2t2,2t1+1)
          ! Ez=E(2t3,2t2,2t1)
          ! values of it1,it2,it3 in table 3-c
          ! x-direction and y-direction
          it3 = (nc-1)/2
          it2 = lc/2
          it1 = mc/2
          if (s3/=0.) then
            ! it=2*(it1+it2+it3)+1
            it = nc + lc + mc
            pwas3 = as3**it
          end if
          ex = eiip(it1, it2, it3)
          ey = eipi(it1, it2, it3)
          ! z-direction
          it3 = (nc+1)/2
          if (s3/=0.) pwas3 = pwas3*s32
          ! it=2*(it1+it2+it3)+1
          ez = eppp(it1, it2, it3)
          return
        end if
        if (itpar==3) then
          ! E I E and  c<a,b
          ! in table 67-g: Ex=E(2t3,2t2+1,2t1+1)
          ! Ey=E(2t3,2t2,2t1)
          ! Ez=E(2t3+1,2t2,2t1+1)
          ! values of it1,it2,it3 in table 3-g
          ! x-direction
          it3 = nc/2
          it2 = lc/2
          it1 = (mc-1)/2
          if (s3/=0.) then
            ! it=2*(it1+it2+it3)+1
            it = nc + lc + mc
            apwas3 = as3**it
            pwas3 = apwas3
          end if
          ex = epii(it1, it2, it3)
          ! y-direction
          it3 = nc/2
          it2 = lc/2
          it1 = (mc+1)/2
          ! it=2*(it1+it2+it3)+1
          if (s3/=0.) pwas3 = pwas3*s32
          ey = eppp(it1, it2, it3)
          ! z-direction
          it3 = nc/2
          it2 = lc/2
          it1 = (mc-1)/2
          if (s3/=0.) pwas3 = apwas3
          ez = eipi(it1, it2, it3)
          return
        end if
        if (itpar==4) then
          ! E I I and  c<a,b
          ! in table 67-e: Ex=E(2t3+1,2t2+1,2t1+1)
          ! Ey=E(2t3+1,2t2,2t1)
          ! Ez=E(2t3,2t2,2t1+1)
          ! values of it1,it2,it3 in table 3-e
          ! x-direction
          it3 = (nc-1)/2
          it2 = lc/2
          it1 = (mc-1)/2
          if (s3/=0.) then
            ! it=2*(it1+it2+it3)+1
            it = nc + lc + mc - 1
            pwas3 = as3**it
          end if
          ex = eiii(it1, it2, it3)
          ! y-direction
          it3 = (nc-1)/2
          it2 = lc/2
          it1 = (mc+1)/2
          ! it=2*(it1+it2+it3)+1
          if (s3/=0.) pwas3 = pwas3*s32
          ey = eipp(it1, it2, it3)
          ! z-direction
          it3 = (nc+1)/2
          it2 = lc/2
          it1 = (mc-1)/2
          ! it=2*(it1+it2+it3)+1
          ez = eppi(it1, it2, it3)
          return
        end if
        if (itpar==5) then
          ! I E E and  c<a,b
          ! in table 67-h: Ex=E(2t3,2t2,2t1)
          ! Ey=E(2t3,2t2+1,2t1+1)
          ! Ez=E(2t3+1,2t2+1,2t1)
          ! values of it1,it2,it3 in table 3-h
          ! x-direction
          it3 = nc/2
          it2 = (lc+1)/2
          it1 = mc/2
          if (s3/=0.) then
            ! it=2*(it1+it2+it3)+1
            it = nc + lc + mc
            apwas3 = as3**it
            pwas3 = apwas3*s32
          end if
          ex = eppp(it1, it2, it3)
          ! y-direction
          it3 = nc/2
          it2 = (lc-1)/2
          it1 = mc/2
          ! it=2*(it1+it2+it3)+1
          if (s3/=0.) pwas3 = apwas3
          ey = epii(it1, it2, it3)
          ! z-direction
          it3 = nc/2
          it2 = (lc-1)/2
          it1 = mc/2
          ez = eiip(it1, it2, it3)
          return
        end if
        if (itpar==6) then
          ! I E I and  c<a,b
          ! in table 67-d: Ex=E(2t3+1,2t2,2t1)
          ! Ey=E(2t3+1,2t2+1,2t1+1)
          ! Ez=E(2t3,2t2+1,2t1)
          ! values of it1,it2,it3 in table 3-d
          ! x-direction
          it3 = (nc-1)/2
          it2 = (lc+1)/2
          it1 = mc/2
          if (s3/=0.) then
            ! it=2*(it1+it2+it3)+1
            it = nc + lc + mc - 1
            apwas3 = as3**it
            pwas3 = apwas3*s32
          end if
          ex = eipp(it1, it2, it3)
          ! y-direction
          it3 = (nc-1)/2
          it2 = (lc-1)/2
          it1 = mc/2
          ! it=2*(it1+it2+it3)+1
          if (s3/=0.) pwas3 = apwas3
          ey = eiii(it1, it2, it3)
          ! z-direction
          it3 = (nc+1)/2
          it2 = (lc-1)/2
          it1 = mc/2
          ! it=2*(it1+it2+it3)+1
          if (s3/=0.) pwas3 = pwas3*s32
          ez = epip(it1, it2, it3)
          return
        end if
        if (itpar==7) then
          ! I I E and  c<a,b
          ! in table 67-f: Ex=E(2t3,2t2,2t1+1)
          ! Ey=E(2t3,2t2+1,2t1)
          ! Ez=E(2t3+1,2t2+1,2t1+1)
          ! values of it1,it2,it3 in table 3-f
          ! x-direction
          it3 = nc/2
          it2 = (lc+1)/2
          it1 = (mc-1)/2
          if (s3/=0.) then
            ! it=2*(it1+it2+it3)+1
            it = nc + lc + mc - 1
            apwas3 = as3**it
            pwas3 = apwas3*s32
          end if
          ex = eppi(it1, it2, it3)
          ! y-direction
          it3 = nc/2
          it2 = (lc-1)/2
          it1 = (mc+1)/2
          ! it=2*(it1+it2+it3)+1
          ey = epip(it1, it2, it3)
          ! z-direction
          it3 = nc/2
          it2 = (lc-1)/2
          it1 = (mc-1)/2
          ! it=2*(it1+it2+it3)+1
          if (s3/=0.) pwas3 = apwas3
          ez = eiii(it1, it2, it3)
          return
        end if
        if (itpar==8) then
          ! I I I and  c<a,b
          ! in table 67-b: Ex=E(2t3+1,2t2,2t1+1)
          ! Ey=E(2t3+1,2t2+1,2t1)
          ! Ez=E(2t3,2t2+1,2t1+1)
          ! values of it1,it2,it3 in table 3-b
          ! x-direction
          it3 = (nc-1)/2
          it2 = (lc+1)/2
          it1 = (mc-1)/2
          ! it=2*(it1+it2+it3)+1
          if (s3/=0.) then
            it = nc + lc + mc
            pwas3 = as3**it
          end if
          ex = eipi(it1, it2, it3)
          ! y-direction
          it3 = (nc-1)/2
          it2 = (lc-1)/2
          it1 = (mc+1)/2
          ! it=2*(it1+it2+it3)+1
          ey = eiip(it1, it2, it3)
          ! z-direction
          it3 = (nc+1)/2
          it2 = (lc-1)/2
          it1 = (mc-1)/2
          ! it=2*(it1+it2+it3)+1
          ez = eppi(it1, it2, it3)
          return
        end if
        ! endif of isucc=3----> c<a,b
      end if
    end subroutine fielde
    ! *******************************************************************
    ! FUNCTION eppp(it1,it2,it3)
    ! E(2it3,2it2,2it1)   table 77-a-1
    ! *******************************************************************
    function eppp(it1, it2, it3)
      implicit real *8(a-h, o-z)
      common /rms/rms(3, 50), s1, s2, s3
      common /partcl/x, y, z
      common /const/pi2, sqpi, pwtpi, sqpi2, sq2pi
      ! pi2=pi*pi, sqpi=(pi/2)**3/2
      common /randu/ck(15), kmax
      common /cars3/exs3, exs2, exs1, as3, sgns3, s32, pwas3, pw3as3
      ! exs3=exp(-s3*s3/2),abs3=abs(s3),isgns3=sign s3,s32=s3*s3
      ! pwas3=as3**(2(it1+it2+it3)+1)
      eppp = 0.
      isgnw = 4*(it2+it1) + 5*it3
      ipar = isgnw - 2*(isgnw/2)
      wsng = -1.
      if (ipar==0) wsng = 1.
      eppp = wsng*pi2*exs3*rms(3, 3)
      eppp = eppp*(tppp(it1,it2,it3)+sppp(it1,it2,it3))
      eppp = eppp - 8.*wsng*rms(3, 3)*sqpi*sgppp(it1, it2, it3)
      if (s3/=0.) then
        sgn1 = -1.
        sgn2 = 1.
        isgn1 = 3*(it1+it2) + 4*it3
        ipar = isgn1 - 2*(isgn1/2)
        if (ipar==0) then
          sgn1 = 1.
          sgn2 = -1
        end if
        ipt12 = 2*it1 + 1
        ipt22 = 2*it2 + 1
        ipt212 = 2*(it1+it2)
        rint = rms(1, ipt12+1)*rms(2, ipt22+1)/rms(3, ipt212+1)
        e1 = 2.*sgn1*pi2*pwas3*rint*uppp(it1, it2, it3)
        scum = 0.
        kj = 1
        pcas3 = pwas3
        do k = 1, kmax, 2
          scum = scum + ck(k)*pcas3*vppp(kj)
          kj = kj + 1
          pcas3 = pcas3*s32
        end do
        e2 = scum*sgn2*2.*pi2*rint*exs3
        eppp = eppp + e1 + e2
      end if
      return
    end function eppp
    ! *******************************************************************
    ! FUNCTION epip(it1,it2,it3)
    ! E(2it3,2it2+1,2it1)  table 77-a-2
    ! *******************************************************************
    function epip(it1, it2, it3)
      implicit real *8(a-h, o-z)
      common /rms/rms(3, 50), s1, s2, s3
      common /partcl/x, y, z
      common /const/pi2, sqpi, pwtpi, sqpi2, sq2pi
      common /randu/ck(15), kmax
      ! pi2=pi*pi, sqpi=(pi/2)**3/2
      common /cars3/exs3, exs2, exs1, as3, sgns3, s32, pwas3, pw3as3
      ! exs3=exp(-s3*s3/2),abs3=abs(s3),isgns3=sign s3,s32=s3*s3
      ! pwas3=as3**(2(it1+it2+it3)+1)
      epip = 0.
      isgnw = 4*(it2+it1) + 5*it3 + 2
      ipar = isgnw - 2*(isgnw/2)
      wsng = -1.
      if (ipar==0) wsng = 1.
      epip = wsng*pi2*exs3*rms(3, 3)
      epip = epip*(tpip(it1,it2,it3)+spip(it1,it2,it3))
      epip = epip - 8.*wsng*rms(3, 3)*sqpi*sgpip(it1, it2, it3)
      if (s3/=0.) then
        pwas31 = pwas3*as3
        sgn1 = -1.
        sgn2 = 1.
        isgn1 = 3*(it1+it2) + 4*it3 + 2
        ipar = isgn1 - 2*(isgn1/2)
        if (ipar==0) then
          sgn1 = 1.
          sgn2 = -1.
        end if
        ipt12 = 2*it1 + 1
        ipt22 = 2*it2 + 2
        ipt212 = 2*(it1+it2) + 1
        rint = rms(1, ipt12+1)*rms(2, ipt22+1)/rms(3, ipt212+1)
        e1 = 2.*sgn1*pi2*pwas31*rint*upip(it1, it2, it3)
        scum = 0.
        kj = 1
        pcas3 = pwas31
        do k = 1, kmax, 2
          scum = scum + ck(k)*pcas3*vpip(kj)
          kj = kj + 1
          pcas3 = pcas3*s32
        end do
        e2 = scum*sgn2*2.*pi2*rint*exs3
        epip = epip + (e1+e2)
      end if
      return
    end function epip
    ! *******************************************************************
    ! FUNCTION eppi(it1,it2,it3)
    ! E(2it3,2it2,2it1+1) table 77-a-2
    ! *******************************************************************
    function eppi(it1, it2, it3)
      implicit real *8(a-h, o-z)
      common /rms/rms(3, 50), s1, s2, s3
      common /partcl/x, y, z
      common /const/pi2, sqpi, pwtpi, sqpi2, sq2pi
      common /randu/ck(15), kmax
      common /cars3/exs3, exs2, exs1, as3, sgns3, s32, pwas3, pw3as3
      ! exs3=exp(-s3*s3/2),abs3=abs(s3),isgns3=sign s3,s32=s3*s3
      ! pwas3=as3**(2(it1+it2+it3)+1),pw3as3=as3**(2*it3)
      eppi = 0.
      isgnw = 4*(it2+it1) + 5*it3 + 2
      ipar = isgnw - 2*(isgnw/2)
      wsng = -1.
      if (ipar==0) wsng = 1.
      eppi = wsng*pi2*exs3*rms(3, 3)
      eppi = eppi*(tppi(it1,it2,it3)+sppi(it1,it2,it3))
      eppi = eppi - 8.*wsng*rms(3, 3)*sqpi*sgppi(it1, it2, it3)
      if (s3/=0.) then
        pwas31 = pwas3*as3
        sgn1 = -1.
        sgn2 = 1.
        isgn1 = 3*(it1+it2) + 4*it3 + 2
        xsgn1 = isgn1
        pari = xsgn1 - 2.*int(xsgn1/2.+0.0001)
        if (pari==0.) then
          sgn1 = 1.
          sgn2 = -1.
        end if
        ipt12 = 2*it1 + 2
        ipt22 = 2*it2 + 1
        ipt212 = 2*(it1+it2) + 1
        rint = rms(1, ipt12+1)*rms(2, ipt22+1)/rms(3, ipt212+1)
        e1 = 2.*sgn1*pi2*pwas31*rint*uppi(it1, it2, it3)
        scum = 0.
        kj = 1
        pcas3 = pwas31
        do k = 1, kmax, 2
          scum = scum + ck(k)*pcas3*vppi(kj)
          kj = kj + 1
          pcas3 = pcas3*s32
        end do
        e2 = scum*sgn2*2.*pi2*rint*exs3
        eppi = eppi + (e1+e2)
      end if
      return
    end function eppi
    ! *******************************************************************
    ! FUNCTION epii(it1,it2,it3)
    ! E(2*it3,2*it2+1,2*it1+1) table 77-a-1
    ! *******************************************************************
    function epii(it1, it2, it3)
      implicit real *8(a-h, o-z)
      common /rms/rms(3, 50), s1, s2, s3
      common /partcl/x, y, z
      common /const/pi2, sqpi, pwtpi, sqpi2, sq2pi
      common /randu/ck(15), kmax
      ! pi2=pi*pi, sqpi=(pi/2)**3/2
      common /cars3/exs3, exs2, exs1, as3, sgns3, s32, pwas3, pw3as3
      ! exs3=exp(-s3*s3/2),abs3=abs(s3),isgns3=sign s3,s32=s3*s3
      ! pwas3=as3**(2(it1+it2+it3)+1),pw3as3=as3**(2*it3)
      epii = 0.
      isgnw = 4*(it2+it1) + 5*it3 + 4
      ipar = isgnw - 2*(isgnw/2)
      wsng = -1.
      if (ipar==0) wsng = 1.
      epii = wsng*pi2*exs3*rms(3, 3)
      epii = epii*(tpii(it1,it2,it3)+spii(it1,it2,it3))
      epii = epii - 8.*wsng*rms(3, 3)*sqpi*sgpii(it1, it2, it3)
      if (s3/=0.) then
        pwas31 = pwas3*s32
        sgn1 = -1.
        sgn2 = 1.
        isgn1 = 3*(it1+it2) + 4*it3 + 4
        ipar = isgn1 - 2*(isgn1/2)
        if (ipar==0) then
          sgn1 = 1.
          sgn2 = -1
        end if
        ipt12 = 2*it1 + 2
        ipt22 = 2*it2 + 2
        ipt212 = 2*(it1+it2+1)
        rint = rms(1, ipt12+1)*rms(2, ipt22+1)/rms(3, ipt212+1)
        e1 = 2.*sgn1*pi2*pwas31*rint*upii(it1, it2, it3)
        scum = 0.
        kj = 1
        pcas3 = pwas31
        do k = 1, kmax, 2
          scum = scum + ck(k)*pcas3*vpii(kj)
          kj = kj + 1
          pcas3 = pcas3*s32
        end do
        e2 = scum*sgn2*2.*pi2*rint*exs3
        epii = epii + e1 + e2
      end if
      return
    end function epii
    ! *******************************************************************
    ! FUNCTION eipp(it1,it2,it3)
    ! E(2it3+1,2it2,2it1) table 77-b-2
    ! *******************************************************************
    function eipp(it1, it2, it3)
      implicit real *8(a-h, o-z)
      common /rms/rms(3, 50), s1, s2, s3
      common /partcl/x, y, z
      common /const/pi2, sqpi, pwtpi, sqpi2, sq2pi
      common /randu/ck(15), kmax
      ! pi2=pi*pi, sqpi=(pi/2)**3/2
      common /cars3/exs3, exs2, exs1, as3, sgns3, s32, pwas3, pw3as3
      ! exs3=exp(-s3*s3/2),abs3=abs(s3),sgns3=sign s3,s32=s3*s3
      ! pwas3=as3**(2(it1+it2+it3)+1),pw3as3=as3**(2*it3)
      eipp = 0.
      isgnw = 4*(it2+it1) + 5*it3 + 3
      ipar = isgnw - 2*(isgnw/2)
      wsng = -1.
      if (ipar==0) wsng = 1.
      eipp = wsng*sgns3*pi2*exs3*rms(3, 3)
      eipp = eipp*(tipp(it1,it2,it3)+sipp(it1,it2,it3))
      eipp = eipp + 8.*wsng*rms(3, 3)*sqpi*sgipp(it1, it2, it3)
      if (s3/=0.) then
        pwas31 = pwas3*as3
        sgn1 = -1.
        sgn2 = 1.
        isgn1 = 3*(it1+it2) + 4*it3 + 3
        ipar = isgn1 - 2*(isgn1/2)
        if (ipar==0) then
          sgn1 = 1.
          sgn2 = -1
        end if
        ipt12 = 2*it1 + 1
        ipt22 = 2*it2 + 1
        ipt212 = 2*(it1+it2)
        rint = rms(1, ipt12+1)*rms(2, ipt22+1)/rms(3, ipt212+1)
        e1 = 2.*sgn1*pi2*pwas31*rint*uipp(it1, it2, it3)*sgns3
        scum = 0.
        kj = 1
        pcas3 = pwas31
        do k = 1, kmax, 2
          scum = scum + ck(k)*pcas3*vipp(kj)
          kj = kj + 1
          pcas3 = pcas3*s32
        end do
        e2 = scum*sgn2*2.*pi2*rint*exs3*sgns3
        eipp = eipp - (e1+e2)
      end if
      return
    end function eipp
    ! *******************************************************************
    ! FUNCTION eiip(it1,it2,it3)
    ! E(2it3+1,2it2+1,2it1)  table 77-b-1
    ! *******************************************************************
    function eiip(it1, it2, it3)
      implicit real *8(a-h, o-z)
      common /rms/rms(3, 50), s1, s2, s3
      common /partcl/x, y, z
      common /const/pi2, sqpi, pwtpi, sqpi2, sq2pi
      common /randu/ck(15), kmax
      ! pi2=pi*pi, sqpi=(pi/2)**3/2
      common /cars3/exs3, exs2, exs1, as3, sgns3, s32, pwas3, pw3as3
      ! exs3=exp(-s3*s3/2),abs3=abs(s3),sgns3=sign s3,s32=s3*s3
      ! pwas3=as3**(2(it1+it2+it3)+1)
      eiip = 0.
      isgnw = 4*(it2+it1) + 5*it3 + 5
      ipar = isgnw - 2*(isgnw/2)
      wsng = -1.
      if (ipar==0) wsng = 1.
      eiip = wsng*sgns3*pi2*exs3*rms(3, 3)
      eiip = eiip*(tiip(it1,it2,it3)+siip(it1,it2,it3))
      eiip = eiip + 8.*wsng*rms(3, 3)*sqpi*sgiip(it1, it2, it3)
      if (s3/=0.) then
        pwas31 = pwas3*s32
        sgn1 = -1.
        sgn2 = 1.
        isgn1 = 3*(it1+it2) + 4*it3 + 5
        ipar = isgn1 - 2*(isgn1/2)
        if (ipar==0) then
          sgn1 = 1.
          sgn2 = -1
        end if
        ipt12 = 2*it1 + 1
        ipt22 = 2*it2 + 2
        ipt212 = 2*(it1+it2) + 1
        rint = rms(1, ipt12+1)*rms(2, ipt22+1)/rms(3, ipt212+1)
        e1 = 2.*sgn1*pi2*pwas31*rint*uiip(it1, it2, it3)*sgns3
        scum = 0.
        kj = 1
        pcas3 = pwas31
        do k = 1, kmax, 2
          scum = scum + ck(k)*pcas3*viip(kj)
          kj = kj + 1
          pcas3 = pcas3*s32
        end do
        e2 = scum*sgn2*2.*pi2*rint*exs3*sgns3
        eiip = eiip - (e1+e2)
      end if
      return
    end function eiip
    ! *******************************************************************
    ! FUNCTION eipi(it1,it2,it3)
    ! E(2*it3+1,2*it2,2*it1+1)  table 77-b-1
    ! *******************************************************************
    function eipi(it1, it2, it3)
      implicit real *8(a-h, o-z)
      common /rms/rms(3, 50), s1, s2, s3
      common /partcl/x, y, z
      common /const/pi2, sqpi, pwtpi, sqpi2, sq2pi
      common /randu/ck(15), kmax
      ! pi2=pi*pi, sqpi=(pi/2)**3/2
      common /cars3/exs3, exs2, exs1, as3, sgns3, s32, pwas3, pw3as3
      ! exs3=exp(-s3*s3/2),abs3=abs(s3),sgns3=sign s3,s32=s3*s3
      ! pwas3=as3**(2(it1+it2+it3)+1)
      eipi = 0.
      isgnw = 4*(it2+it1) + 5*it3 + 5
      ipar = isgnw - 2*(isgnw/2)
      wsng = -1.
      if (ipar==0) wsng = 1.
      eipi = wsng*sgns3*pi2*exs3*rms(3, 3)
      eipi = eipi*(tipi(it1,it2,it3)+sipi(it1,it2,it3))
      eipi = eipi + 8.*wsng*rms(3, 3)*sqpi*sgipi(it1, it2, it3)
      if (s3/=0.) then
        pwas31 = pwas3*s32
        sgn1 = -1.
        sgn2 = 1.
        isgn1 = 3*(it1+it2) + 4*it3 + 5
        ipar = isgn1 - 2*(isgn1/2)
        if (ipar==0) then
          sgn1 = 1.
          sgn2 = -1
        end if
        ipt12 = 2*it1 + 2
        ipt22 = 2*it2 + 1
        ipt212 = 2*(it1+it2) + 1
        rint = rms(1, ipt12+1)*rms(2, ipt22+1)/rms(3, ipt212+1)
        e1 = 2.*sgn1*pi2*pwas31*rint*uipi(it1, it2, it3)*sgns3
        scum = 0.
        kj = 1
        pcas3 = pwas31
        do k = 1, kmax, 2
          scum = scum + ck(k)*pcas3*vipi(kj)
          kj = kj + 1
          pcas3 = pcas3*s32
        end do
        e2 = scum*sgn2*2.*pi2*rint*exs3*sgns3
        eipi = eipi - (e1+e2)
      end if
      return
    end function eipi
    ! *******************************************************************
    ! FUNCTION eiii(it1,it2,it3)
    ! E(2*it3+1,2*it2+1,2*it1+1) table 77-b-2
    ! *******************************************************************
    function eiii(it1, it2, it3)
      implicit real *8(a-h, o-z)
      common /rms/rms(3, 50), s1, s2, s3
      common /partcl/x, y, z
      common /const/pi2, sqpi, pwtpi, sqpi2, sq2pi
      common /randu/ck(15), kmax
      ! pi2=pi*pi, sqpi=(pi/2)**3/2
      common /cars3/exs3, exs2, exs1, as3, sgns3, s32, pwas3, pw3as3
      ! exs3=exp(-s3*s3/2),abs3=abs(s3),sgns3=sign s3,s32=s3*s3
      ! pwas3=as3**(2(it1+it2+it3)+1),pw3as3=as3**(2*it3)
      eiii = 0.
      isgnw = 4*(it2+it1) + 5*it3 + 5
      ipar = isgnw - 2*(isgnw/2)
      wsng = -1.
      if (ipar==0) wsng = 1.
      eiii = wsng*sgns3*pi2*exs3*rms(3, 3)
      eiii = eiii*(tiii(it1,it2,it3)+siii(it1,it2,it3))
      eiii = eiii + 8.*wsng*rms(3, 3)*sqpi*sgiii(it1, it2, it3)
      if (s3/=0.) then
        pwas31 = pwas3*s32*as3
        sgn1 = -1.
        sgn2 = 1.
        isgn1 = 3*(it1+it2) + 4*it3 + 5
        ipar = isgn1 - 2*(isgn1/2)
        if (ipar==0) then
          sgn1 = 1.
          sgn2 = -1
        end if
        ipt12 = 2*it1 + 2
        ipt22 = 2*it2 + 2
        ipt212 = 2*(it1+it2) + 2
        rint = rms(1, ipt12+1)*rms(2, ipt22+1)/rms(3, ipt212+1)
        e1 = 2.*sgn1*pi2*pwas31*rint*uiii(it1, it2, it3)*sgns3
        scum = 0.
        kj = 1
        pcas3 = pwas31
        do k = 1, kmax, 2
          scum = scum + ck(k)*pcas3*viii(kj)
          kj = kj + 1
          pcas3 = pcas3*s32
        end do
        e2 = scum*sgn2*2.*pi2*rint*exs3*sgns3
        eiii = eiii - (e1+e2)
      end if
      return
    end function eiii
    ! *******************************************************************
    ! FUNCTION tipp(it1,it2,it3)
    ! Part of W**(2t3+1,2t2,2t1)  table 61-b
    ! with T(2t3+1,2t2,2t1,j1)    table 41
    ! *******************************************************************
    function tipp(it1, it2, it3)
      implicit real *8(a-h, o-z)
      common /randu/ck(15), kmax
      common /gauss1/absg(40), wg(40), igaus
      common /circu/co(40, 50), sn(40, 50), blam(40, 100)
      common /rms/rms(3, 50), s1, s2, s3
      common /cars3/exs3, exs2, exs1, as3, sgns3, s32, pwas3, pw3as3
      common /comtab/hsint(40, 2, 60), sqblam(40), s3pw(15)
      common /herfun/hs1(60), hs2(60), hs3(60)
      common /const/pi2, sqpi, pwtpi, sqpi2, sq2pi
      common /ftsk/stc1i(8, 8, 40), stc1p(8, 8, 40), stc2i(8, 8), stc2p(8, 8)
      common /ftth/makti, maktp
      logical makti, maktp

      tipp = 0.
      if (.not. makti) then
        makti = .true.
        kk = 1
        do k = 2, kmax, 2
          km1 = k - 1
          tt1 = 0.
          jm1 = 0
          xsj1 = 1.
          jj1 = 1
          do j1 = 1, km1, 2
            j1km = km1 - 2*jm1
            ! term T(2t3+1,2t2,2t1,j1) in table 41
            it3j1 = it3 + jm1
            tt = 0.
            mm = 1
            do m = 1, it3j1 + 1
              mm1 = m - 1
              stoc = rms(1, 2*mm1+1)*rms(2, 2*(it3j1-mm1)+1)
              stc1i(kk, jj1, mm) = fpar(it3j1, mm1)/stoc
              it23jm = 2*(it2+it3+jm1-mm1)
              it1m = 2*(it1+mm1)
              tt = tt + stc1i(kk, jj1, mm)*hs2(it23jm+1)*hs1(it1m+1)
              mm = mm + 1
            end do
            ! s3pw(j1km+1)=as3**j1km
            stoc = rms(3, 2*it3j1+1)*s3pw(j1km+1)*xsj1
            stc2i(kk, jj1) = 2.*fpar(km1, 2*jm1)*stoc
            tt1 = tt1 + tt*stc2i(kk, jj1)
            xsj1 = -xsj1
            jm1 = jm1 + 1
            jj1 = jj1 + 1
          end do
          tipp = tt1*ck(k) + tipp
          kk = kk + 1
        end do
        return
      else
        kk = 1
        do k = 2, kmax, 2
          km1 = k - 1
          tt1 = 0.
          jm1 = 0
          jj1 = 1
          do j1 = 1, km1, 2
            j1km = km1 - 2*jm1
            ! term T(2t3+1,2t2,2t1,j1) in table 41
            it3j1 = it3 + jm1
            tt = 0.
            mm = 1
            do m = 1, it3j1 + 1
              mm1 = m - 1
              it23jm = 2*(it2+it3+jm1-mm1)
              it1m = 2*(it1+mm1)
              tt = tt + stc1i(kk, jj1, mm)*hs2(it23jm+1)*hs1(it1m+1)
              mm1 = mm1 + 1
            end do
            tt1 = tt1 + tt*stc2i(kk, jj1)
            jm1 = jm1 + 1
            jj1 = jj1 + 1
          end do
          tipp = tt1*ck(k) + tipp
          kk = kk + 1
        end do
        return
      end if
    end function tipp
    ! *******************************************************************
    ! FUNCTION tiip(it1,it2,it3)
    ! part of W**(2t3+1,2t2+1,2t1)  table 61-b
    ! with  T(2t3+1,2t2+1,2t1,j1)   table 41
    ! *******************************************************************
    function tiip(it1, it2, it3)
      implicit real *8(a-h, o-z)
      common /randu/ck(15), kmax
      common /gauss1/absg(40), wg(40), igaus
      common /circu/co(40, 50), sn(40, 50), blam(40, 100)
      common /rms/rms(3, 50), s1, s2, s3
      common /cars3/exs3, exs2, exs1, as3, sgns3, s32, pwas3, pw3as3
      common /comtab/hsint(40, 2, 60), sqblam(40), s3pw(15)
      common /herfun/hs1(60), hs2(60), hs3(60)
      common /const/pi2, sqpi, pwtpi, sqpi2, sq2pi
      common /ftsk/stc1i(8, 8, 40), stc1p(8, 8, 40), stc2i(8, 8), stc2p(8, 8)
      common /ftth/makti, maktp
      logical makti, maktp

      tiip = 0.
      if (.not. makti) then
        makti = .true.
        kk = 1
        do k = 2, kmax, 2
          km1 = k - 1
          tt1 = 0.
          jm1 = 0
          xsj1 = 1.
          jj1 = 1
          do j1 = 1, km1, 2
            j1km = km1 - 2*jm1
            it3j1 = it3 + jm1
            tt = 0.
            mm = 1
            do m = 1, it3j1 + 1
              mm1 = m - 1
              stoc = rms(1, 2*mm1+1)*rms(2, 2*(it3j1-mm1)+1)
              stc1i(kk, jj1, mm) = fpar(it3j1, mm1)/stoc
              it23jm = 2*(it2+it3+jm1-mm1)
              it1m = 2*(it1+mm1)
              tt = tt + stc1i(kk, jj1, mm)*hs2(it23jm+2)*hs1(it1m+1)
              mm = mm + 1
            end do
            ! s3pw(j1km+1)=as3**j1km
            stoc = rms(3, 2*it3j1+1)*s3pw(j1km+1)*xsj1
            stc2i(kk, jj1) = 2.*fpar(km1, 2*jm1)*stoc
            tt1 = tt1 + tt*stc2i(kk, jj1)
            xsj1 = -xsj1
            jm1 = jm1 + 1
            jj1 = jj1 + 1
          end do
          tiip = tt1*ck(k) + tiip
          kk = kk + 1
        end do
        return
      else
        kk = 1
        do k = 2, kmax, 2
          km1 = k - 1
          tt1 = 0.
          jm1 = 0
          jj1 = 1
          do j1 = 1, km1, 2
            j1km = km1 - 2*jm1
            ! term T(2t3+1,2t2,2t1,j1) in table 41
            it3j1 = it3 + jm1
            tt = 0.
            mm = 1
            do m = 1, it3j1 + 1
              mm1 = m - 1
              it23jm = 2*(it2+it3+jm1-mm1)
              it1m = 2*(it1+mm1)
              tt = tt + stc1i(kk, jj1, mm)*hs2(it23jm+2)*hs1(it1m+1)
              mm = mm + 1
            end do
            tt1 = tt1 + tt*stc2i(kk, jj1)
            jm1 = jm1 + 1
            jj1 = jj1 + 1
          end do
          tiip = tt1*ck(k) + tiip
          kk = kk + 1
        end do
        return
      end if
    end function tiip
    ! *******************************************************************
    ! FUNCTION tipi(it1,it2,it3)
    ! part of W**(2t3+1,2t2,2t1+1) in table 61-b
    ! with T(2t3+1,2t2,2t1+1,j1)   in table 41
    ! *******************************************************************
    function tipi(it1, it2, it3)
      implicit real *8(a-h, o-z)
      common /randu/ck(15), kmax
      common /gauss1/absg(40), wg(40), igaus
      common /circu/co(40, 50), sn(40, 50), blam(40, 100)
      common /rms/rms(3, 50), s1, s2, s3
      common /cars3/exs3, exs2, exs1, as3, sgns3, s32, pwas3, pw3as3
      common /comtab/hsint(40, 2, 60), sqblam(40), s3pw(15)
      common /herfun/hs1(60), hs2(60), hs3(60)
      common /const/pi2, sqpi, pwtpi, sqpi2, sq2pi
      common /ftsk/stc1i(8, 8, 40), stc1p(8, 8, 40), stc2i(8, 8), stc2p(8, 8)
      common /ftth/makti, maktp
      logical makti, maktp

      tipi = 0.
      if (.not. makti) then
        makti = .true.
        kk = 1
        do k = 2, kmax, 2
          km1 = k - 1
          tt1 = 0.
          jm1 = 0
          xsj1 = 1.
          jj1 = 1
          do j1 = 1, km1, 2
            j1km = km1 - 2*jm1
            ! term T(2t3+1,2t2+1,2t1,j1) in table 41
            it3j1 = it3 + jm1
            tt = 0.
            mm = 1
            do m = 1, it3j1 + 1
              mm1 = m - 1
              stoc = rms(1, 2*mm1+1)*rms(2, 2*(it3j1-mm1)+1)
              stc1i(kk, jj1, mm) = fpar(it3j1, mm1)/stoc
              it23jm = 2*(it2+it3+jm1-mm1)
              it1m = 2*(it1+mm1)
              tt = tt + stc1i(kk, jj1, mm)*hs2(it23jm+1)*hs1(it1m+2)
              mm = mm + 1
            end do
            ! s3pw(j1km+1)=as3**j1km
            stoc = rms(3, 2*it3j1+1)*s3pw(j1km+1)*xsj1
            stc2i(kk, jj1) = 2.*fpar(km1, 2*jm1)*stoc
            tt1 = tt1 + tt*stc2i(kk, jj1)
            xsj1 = -xsj1
            jm1 = jm1 + 1
            jj1 = jj1 + 1
          end do
          tipi = tt1*ck(k) + tipi
          kk = kk + 1
        end do
        return
      else
        kk = 1
        do k = 2, kmax, 2
          km1 = k - 1
          tt1 = 0.
          jm1 = 0
          jj1 = 1
          do j1 = 1, km1, 2
            j1km = km1 - 2*jm1
            ! term T(2t3+1,2t2,2t1,j1) in table 41
            it3j1 = it3 + jm1
            tt = 0.
            mm = 1
            do m = 1, it3j1 + 1
              mm1 = m - 1
              it23jm = 2*(it2+it3+jm1-mm1)
              it1m = 2*(it1+mm1)
              tt = tt + stc1i(kk, jj1, mm)*hs2(it23jm+1)*hs1(it1m+2)
              mm = mm + 1
            end do
            tt1 = tt1 + tt*stc2i(kk, jj1)
            jm1 = jm1 + 1
            jj1 = jj1 + 1
          end do
          tipi = tt1*ck(k) + tipi
          kk = kk + 1
        end do
        return
      end if
    end function tipi
    ! *******************************************************************
    ! FUNCTION tiii(it1,it2,it3)
    ! part of W**(2t3+1,2t2+1,2t1+1) in table 61-b
    ! with T(2t3+1,2t2+1,2t1+1,j1)   in table 41
    ! *******************************************************************
    function tiii(it1, it2, it3)
      implicit real *8(a-h, o-z)
      common /randu/ck(15), kmax
      common /gauss1/absg(40), wg(40), igaus
      common /circu/co(40, 50), sn(40, 50), blam(40, 100)
      common /rms/rms(3, 50), s1, s2, s3
      common /cars3/exs3, exs2, exs1, as3, sgns3, s32, pwas3, pw3as3
      common /comtab/hsint(40, 2, 60), sqblam(40), s3pw(15)
      common /herfun/hs1(60), hs2(60), hs3(60)
      common /const/pi2, sqpi, pwtpi, sqpi2, sq2pi
      common /ftsk/stc1i(8, 8, 40), stc1p(8, 8, 40), stc2i(8, 8), stc2p(8, 8)
      common /ftth/makti, maktp
      logical makti, maktp

      tiii = 0.
      if (.not. makti) then
        makti = .true.
        kk = 1
        do k = 2, kmax, 2
          km1 = k - 1
          tt1 = 0.
          jm1 = 0
          xsj1 = 1.
          jj1 = 1
          do j1 = 1, km1, 2
            j1km = km1 - 2*jm1
            ! term T(2t3+1,2t2+1,2t1,j1) in table 41
            it3j1 = it3 + jm1
            tt = 0.
            mm = 1
            do m = 1, it3j1 + 1
              mm1 = m - 1
              stoc = rms(1, 2*mm1+1)*rms(2, 2*(it3j1-mm1)+1)
              stc1i(kk, jj1, mm) = fpar(it3j1, mm1)/stoc
              it23jm = 2*(it2+it3+jm1-mm1)
              it1m = 2*(it1+mm1)
              tt = tt + stc1i(kk, jj1, mm)*hs2(it23jm+2)*hs1(it1m+2)
              mm = mm + 1
            end do
            ! s3pw(j1km+1)=as3**j1km
            stoc = rms(3, 2*it3j1+1)*s3pw(j1km+1)*xsj1
            stc2i(kk, jj1) = 2.*fpar(km1, 2*jm1)*stoc
            tt1 = tt1 + tt*stc2i(kk, jj1)
            xsj1 = -xsj1
            jm1 = jm1 + 1
            jj1 = jj1 + 1
          end do
          tiii = tt1*ck(k) + tiii
          kk = kk + 1
        end do
        return
      else
        kk = 1
        do k = 2, kmax, 2
          km1 = k - 1
          tt1 = 0.
          jm1 = 0
          jj1 = 1
          do j1 = 1, km1, 2
            j1km = km1 - 2*jm1
            ! term T(2t3+1,2t2+1,2t1+1,j1) in table 41
            it3j1 = it3 + jm1
            tt = 0.
            mm = 1
            do m = 1, it3j1 + 1
              mm1 = m - 1
              it23jm = 2*(it2+it3+jm1-mm1)
              it1m = 2*(it1+mm1)
              tt = tt + stc1i(kk, jj1, mm)*hs2(it23jm+2)*hs1(it1m+2)
              mm1 = mm1 + 1
            end do
            tt1 = tt1 + tt*stc2i(kk, jj1)
            jm1 = jm1 + 1
            jj1 = jj1 + 1
          end do
          tiii = tt1*ck(k) + tiii
          kk = kk + 1
        end do
        return
      end if
    end function tiii
    ! *******************************************************************
    ! FUNCTION tppp(it1,it2,it3)
    ! part of W**(2t3,2t2,2t1) in table 61-a
    ! with  T(2t3,2t2,2t1,j1)  in table 41
    ! *******************************************************************
    function tppp(it1, it2, it3)
      implicit real *8(a-h, o-z)
      common /randu/ck(15), kmax
      common /gauss1/absg(40), wg(40), igaus
      common /circu/co(40, 50), sn(40, 50), blam(40, 100)
      common /rms/rms(3, 50), s1, s2, s3
      common /cars3/exs3, exs2, exs1, as3, sgns3, s32, pwas3, pw3as3
      common /comtab/hsint(40, 2, 60), sqblam(40), s3pw(15)
      common /herfun/hs1(60), hs2(60), hs3(60)
      common /const/pi2, sqpi, pwtpi, sqpi2, sq2pi
      common /ftsk/stc1i(8, 8, 40), stc1p(8, 8, 40), stc2i(8, 8), stc2p(8, 8)
      common /ftth/makti, maktp
      logical makti, maktp

      tppp = 0.
      if (.not. maktp) then
        maktp = .true.
        kk = 1
        do k = 2, kmax, 2
          km1 = k - 1
          xsj1 = 1
          tt1 = 0.
          jm1 = 0
          jj1 = 1
          do j1 = 1, km1, 2
            j1km = km1 - 2*jm1 - 1
            ! j1km must be always greather or equal to zero
            if (j1km<0) go to 100
            ! T(2t3,2t2,2t1,j1) in table 41
            it3j1 = it3 + jm1
            tt = 0.
            mm = 1
            do m = 1, it3j1 + 1
              mm1 = m - 1
              stoc = rms(1, 2*mm1+1)*rms(2, 2*(it3j1-mm1)+1)
              stc1p(kk, jj1, mm) = fpar(it3j1, mm1)/stoc
              it23jm = 2*(it2+it3+jm1-mm1)
              it1m = 2*(it1+mm1)
              tt = tt + stc1p(kk, jj1, mm)*hs2(it23jm+1)*hs1(it1m+1)
              mm = mm + 1
            end do
            ! s3pw(j1km+1)=as3**j1km
            stoc = rms(3, 2*it3j1+1)*s3pw(j1km+1)*xsj1
            stc2p(kk, jj1) = 2.*fpar(km1, 2*jm1+1)*stoc
            tt1 = tt1 + tt*stc2p(kk, jj1)
            xsj1 = -xsj1
            jm1 = jm1 + 1
            jj1 = jj1 + 1
          end do
          tppp = tt1*ck(k) + tppp
          kk = kk + 1
100       continue
        end do
        return
      else
        kk = 1
        do k = 2, kmax, 2
          km1 = k - 1
          tt1 = 0.
          jm1 = 0
          jj1 = 1
          do j1 = 1, km1, 2
            j1km = km1 - 2*jm1 - 1
            ! j1km must be always greather or equal to zero
            if (j1km<0) go to 200
            ! T(2t3,2t2,2t1,j1) in table 41
            it3j1 = it3 + jm1
            tt = 0.
            mm = 1
            do m = 1, it3j1 + 1
              mm1 = m - 1
              it23jm = 2*(it2+it3+jm1-mm1)
              it1m = 2*(it1+mm1)
              tt = tt + stc1p(kk, jj1, mm)*hs2(it23jm+1)*hs1(it1m+1)
              mm = mm + 1
            end do
            tt1 = tt1 + tt*stc2p(kk, jj1)
            jm1 = jm1 + 1
            jj1 = jj1 + 1
          end do
          tppp = tt1*ck(k) + tppp
          kk = kk + 1
200       continue
        end do
        return
      end if
    end function tppp
    ! *******************************************************************
    ! FUNCTION tpip(it1,it2,it3)
    ! the part of W**(2t3,2t2,2t1+1) in table 61-a
    ! with T(2t3,2t2,2t1+1,j1)       in table 41
    ! *******************************************************************
    function tpip(it1, it2, it3)
      implicit real *8(a-h, o-z)
      common /randu/ck(15), kmax
      common /gauss1/absg(40), wg(40), igaus
      common /circu/co(40, 50), sn(40, 50), blam(40, 100)
      common /rms/rms(3, 50), s1, s2, s3
      common /cars3/exs3, exs2, exs1, as3, sgns3, s32, pwas3, pw3as3
      common /comtab/hsint(40, 2, 60), sqblam(40), s3pw(15)
      common /herfun/hs1(60), hs2(60), hs3(60)
      common /const/pi2, sqpi, pwtpi, sqpi2, sq2pi
      common /ftsk/stc1i(8, 8, 40), stc1p(8, 8, 40), stc2i(8, 8), stc2p(8, 8)
      common /ftth/makti, maktp
      logical makti, maktp

      tpip = 0.
      if (.not. maktp) then
        maktp = .true.
        kk = 1
        do k = 2, kmax, 2
          km1 = k - 1
          xsj1 = 1
          tt1 = 0.
          jm1 = 0
          jj1 = 1
          do j1 = 1, km1, 2
            j1km = km1 - 2*jm1 - 1
            ! j1km must be always greather or equal to zero
            if (j1km<0) go to 100
            ! T(2t3,2t2,2t1,j1) in table 41
            it3j1 = it3 + jm1
            tt = 0.
            mm = 1
            do m = 1, it3j1 + 1
              mm1 = m - 1
              stoc = rms(1, 2*mm1+1)*rms(2, 2*(it3j1-mm1)+1)
              stc1p(kk, jj1, mm) = fpar(it3j1, mm1)/stoc
              it23jm = 2*(it2+it3+jm1-mm1)
              it1m = 2*(it1+mm1)
              tt = tt + stc1p(kk, jj1, mm)*hs2(it23jm+2)*hs1(it1m+1)
              mm = mm + 1
            end do
            ! s3pw(j1km+1)=as3**j1km
            stoc = rms(3, 2*it3j1+1)*s3pw(j1km+1)*xsj1
            stc2p(kk, jj1) = 2.*fpar(km1, 2*jm1+1)*stoc
            tt1 = tt1 + tt*stc2p(kk, jj1)
            xsj1 = -xsj1
            jm1 = jm1 + 1
            jj1 = jj1 + 1
          end do
          tpip = tt1*ck(k) + tpip
          kk = kk + 1
100       continue
        end do
        return
      else
        kk = 1
        do k = 2, kmax, 2
          km1 = k - 1
          tt1 = 0.
          jm1 = 0
          jj1 = 1
          do j1 = 1, km1, 2
            j1km = km1 - 2*jm1 - 1
            ! j1km must be always greather or equal to zero
            if (j1km<0) go to 200
            ! T(2t3,2t2,2t1,j1) in table 41
            it3j1 = it3 + jm1
            tt = 0.
            mm = 1
            do m = 1, it3j1 + 1
              mm1 = m - 1
              it23jm = 2*(it2+it3+jm1-mm1)
              it1m = 2*(it1+mm1)
              tt = tt + stc1p(kk, jj1, mm)*hs2(it23jm+2)*hs1(it1m+1)
              mm = mm + 1
            end do
            tt1 = tt1 + tt*stc2p(kk, jj1)
            jm1 = jm1 + 1
            jj1 = jj1 + 1
          end do
          tpip = tt1*ck(k) + tpip
          kk = kk + 1
200       continue
        end do
        return
      end if
    end function tpip
    ! *******************************************************************
    ! FUNCTION tppi(it1,it2,it3)
    ! part of W**(2t3,2t2,2t1+1) in table 61-a
    ! with T(2t3,2t2,2t1+1,j1)   in table 41
    ! *******************************************************************
    function tppi(it1, it2, it3)
      implicit real *8(a-h, o-z)
      common /randu/ck(15), kmax
      common /gauss1/absg(40), wg(40), igaus
      common /circu/co(40, 50), sn(40, 50), blam(40, 100)
      common /rms/rms(3, 50), s1, s2, s3
      common /cars3/exs3, exs2, exs1, as3, sgns3, s32, pwas3, pw3as3
      common /comtab/hsint(40, 2, 60), sqblam(40), s3pw(15)
      common /herfun/hs1(60), hs2(60), hs3(60)
      common /const/pi2, sqpi, pwtpi, sqpi2, sq2pi
      common /ftsk/stc1i(8, 8, 40), stc1p(8, 8, 40), stc2i(8, 8), stc2p(8, 8)
      common /ftth/makti, maktp
      logical makti, maktp

      tppi = 0.
      if (.not. maktp) then
        maktp = .true.
        kk = 1
        do k = 2, kmax, 2
          km1 = k - 1
          xsj1 = 1
          tt1 = 0.
          jm1 = 0
          jj1 = 1
          do j1 = 1, km1, 2
            j1km = km1 - 2*jm1 - 1
            ! j1km must be always greather or equal to zero
            if (j1km<0) go to 100
            ! T(2t3,2t2,2t1,j1) in table 41
            it3j1 = it3 + jm1
            tt = 0.
            mm = 1
            do m = 1, it3j1 + 1
              mm1 = m - 1
              stoc = rms(1, 2*mm1+1)*rms(2, 2*(it3j1-mm1)+1)
              stc1p(kk, jj1, mm) = fpar(it3j1, mm1)/stoc
              it23jm = 2*(it2+it3+jm1-mm1)
              it1m = 2*(it1+mm1)
              tt = tt + stc1p(kk, jj1, mm)*hs2(it23jm+1)*hs1(it1m+2)
              mm = mm + 1
            end do
            ! s3pw(j1km+1)=as3**j1km
            stoc = rms(3, 2*it3j1+1)*s3pw(j1km+1)*xsj1
            stc2p(kk, jj1) = 2.*fpar(km1, 2*jm1+1)*stoc
            tt1 = tt1 + tt*stc2p(kk, jj1)
            xsj1 = -xsj1
            jm1 = jm1 + 1
            jj1 = jj1 + 1
          end do
          tppi = tt1*ck(k) + tppi
          kk = kk + 1
100       continue
        end do
        return
      else
        kk = 1
        do k = 2, kmax, 2
          km1 = k - 1
          tt1 = 0.
          jm1 = 0
          jj1 = 1
          do j1 = 1, km1, 2
            j1km = km1 - 2*jm1 - 1
            ! j1km must be always greather or equal to zero
            if (j1km<0) go to 200
            ! T(2t3,2t2,2t1,j1) in table 41
            it3j1 = it3 + jm1
            tt = 0.
            mm = 1
            do m = 1, it3j1 + 1
              mm1 = m - 1
              it23jm = 2*(it2+it3+jm1-mm1)
              it1m = 2*(it1+mm1)
              tt = tt + stc1p(kk, jj1, mm)*hs2(it23jm+1)*hs1(it1m+2)
              mm = mm + 1
            end do
            tt1 = tt1 + tt*stc2p(kk, jj1)
            jm1 = jm1 + 1
            jj1 = jj1 + 1
          end do
          tppi = tt1*ck(k) + tppi
          kk = kk + 1
200       continue
        end do
        return
      end if
    end function tppi
    ! *******************************************************************
    ! FUNCTION tpii(it1,it2,it3)
    ! part of W**(2t3,2t2+1,2t1+1) in table 61-a
    ! with T(2t3,2t2+1,2t1+1,j1)   in table 41
    ! *******************************************************************
    function tpii(it1, it2, it3)
      implicit real *8(a-h, o-z)
      common /randu/ck(15), kmax
      common /gauss1/absg(40), wg(40), igaus
      common /circu/co(40, 50), sn(40, 50), blam(40, 100)
      common /rms/rms(3, 50), s1, s2, s3
      common /cars3/exs3, exs2, exs1, as3, sgns3, s32, pwas3, pw3as3
      common /comtab/hsint(40, 2, 60), sqblam(40), s3pw(15)
      common /herfun/hs1(60), hs2(60), hs3(60)
      common /const/pi2, sqpi, pwtpi, sqpi2, sq2pi
      common /ftsk/stc1i(8, 8, 40), stc1p(8, 8, 40), stc2i(8, 8), stc2p(8, 8)
      common /ftth/makti, maktp
      logical makti, maktp

      tpii = 0.
      if (.not. maktp) then
        maktp = .true.
        kk = 1
        do k = 2, kmax, 2
          km1 = k - 1
          xsj1 = 1
          tt1 = 0.
          jm1 = 0
          jj1 = 1
          do j1 = 1, km1, 2
            j1km = km1 - 2*jm1 - 1
            ! j1km must be always greather or equal to zero
            if (j1km<0) go to 100
            ! T(2t3,2t2,2t1,j1) in table 41
            it3j1 = it3 + jm1
            tt = 0.
            mm = 1
            do m = 1, it3j1 + 1
              mm1 = m - 1
              stoc = rms(1, 2*mm1+1)*rms(2, 2*(it3j1-mm1)+1)
              stc1p(kk, jj1, mm) = fpar(it3j1, mm1)/stoc
              it23jm = 2*(it2+it3+jm1-mm1)
              it1m = 2*(it1+mm1)
              tt = tt + stc1p(kk, jj1, mm)*hs2(it23jm+2)*hs1(it1m+2)
              mm = mm + 1
            end do
            ! s3pw(j1km+1)=as3**j1km
            stoc = rms(3, 2*it3j1+1)*s3pw(j1km+1)*xsj1
            stc2p(kk, jj1) = 2.*fpar(km1, 2*jm1+1)*stoc
            tt1 = tt1 + tt*stc2p(kk, jj1)
            xsj1 = -xsj1
            jm1 = jm1 + 1
            jj1 = jj1 + 1
          end do
          tpii = tt1*ck(k) + tpii
          kk = kk + 1
100       continue
        end do
        return
      else
        kk = 1
        do k = 2, kmax, 2
          km1 = k - 1
          tt1 = 0.
          jm1 = 0
          jj1 = 1
          do j1 = 1, km1, 2
            j1km = km1 - 2*jm1 - 1
            ! j1km must be always greather or equal to zero
            if (j1km<0) go to 200
            ! T(2t3,2t2,2t1,j1) in table 41
            it3j1 = it3 + jm1
            tt = 0.
            mm = 1
            do m = 1, it3j1 + 1
              mm1 = m - 1
              it23jm = 2*(it2+it3+jm1-mm1)
              it1m = 2*(it1+mm1)
              tt = tt + stc1p(kk, jj1, mm)*hs2(it23jm+1)*hs1(it1m+2)
              mm = mm + 1
            end do
            tt1 = tt1 + tt*stc2p(kk, jj1)
            jm1 = jm1 + 1
            jj1 = jj1 + 1
          end do
          tpii = tt1*ck(k) + tpii
          kk = kk + 1
200       continue
        end do
        return
      end if
    end function tpii
    ! *******************************************************************
    ! FUNCTION sipp(it1,it2,it3)
    ! second part of W**(2t3+1,2t2,2t1) in table 61-b
    ! with S(2t3+1,2t2,2t1,j1)  in table 70-b
    ! *******************************************************************
    function sipp(it1, it2, it3)
      implicit real *8(a-h, o-z)
      common /consta/vl, pi, xmat, rpel, qst
      common /randu/ck(15), kmax
      common /gauss1/absg(40), wg(40), igaus
      common /circu/co(40, 50), sn(40, 50), blam(40, 100)
      common /rms/rms(3, 50), s1, s2, s3
      common /comtab/hsint(40, 2, 60), sqblam(40), s3pw(15)
      common /const/pi2, sqpi, pwtpi, sqpi2, sq2pi
      common /cars3/exs3, exs2, exs1, as3, sgns3, s32, pwas3, pw3as3
      common /hass/carg(100), sarg(100), argip(100)
      common /fssk/sstci(8, 8), sstcp(8, 8)
      common /fsth/maksi, maksp
      logical maksi, maksp

      sipp = 0.
      it1p = 2*it1 + 1
      it2p = 2*it2 + 1
      it12p = 2*(it1+it2+1) + 1
      bsp = rms(1, it1p+1)*rms(2, it2p+1)/(sq2pi*rms(3,it12p))
      kk = 1
      do k = 1, kmax, 2
        xsj1 = -1.
        km1 = k - 1
        tt1 = 0.
        jm1 = 0
        jj2 = 1
        do j1 = 1, km1, 2
          jj1 = 2*jm1 + 1
          j1km = km1 - jj1
          if (j1km<0) go to 100
          ! S(2t3+1,2t2,2t1,j1) computation
          ! Gauss quadrature in table 70-b
          i1123j1 = it1 + it2 + it3 + jm1 + 1
          i2123j1 = 2*i1123j1
          tt = 0.
          do ig = 1, igaus
            ! Hermite functions are in the table hsint(ig,,ind )
            ! caution!!! in the table hsint the indice ind is starting from 1
            ! i2123j1 is starting from zero
            base = co(ig, it1p)*sn(ig, it2p)/blam(ig, i1123j1)
            htm0 = hsint(ig, 2, i2123j1+1)
            htp0 = hsint(ig, 1, i2123j1+1)
            tt = tt + base/sqblam(ig)*(htm0+htp0)
          end do
          if (.not. maksi) then
            ! s3pw(j1km+1)=as3**j1km
            stock = 2.*xsj1*s3pw(j1km+1)
            sstci(kk, jj2) = fpar(km1, jj1)*stock
            xsj1 = -xsj1
          end if
          tt1 = sstci(kk, jj2)*tt + tt1
          jj2 = jj2 + 1
          jm1 = jm1 + 1
        end do
        sipp = sipp + tt1*ck(k)
        kk = kk + 1
        ! enddo from k (k=1,kmax+1)
100     continue
      end do
      sipp = sipp*bsp
      maksi = .true.
      return
    end function sipp
    ! *******************************************************************
    ! FUNCTION siip(it1,it2,it3)
    ! W**(2t3+1,2t2+1,2t1)       in table 61-b
    ! with S(2t3+1,2t2+1,2t1,j1) in table 70-b
    ! *******************************************************************
    function siip(it1, it2, it3)
      implicit real *8(a-h, o-z)
      common /consta/vl, pi, xmat, rpel, qst
      common /randu/ck(15), kmax
      common /gauss1/absg(40), wg(40), igaus
      common /circu/co(40, 50), sn(40, 50), blam(40, 100)
      common /rms/rms(3, 50), s1, s2, s3
      common /comtab/hsint(40, 2, 60), sqblam(40), s3pw(15)
      common /const/pi2, sqpi, pwtpi, sqpi2, sq2pi
      common /cars3/exs3, exs2, exs1, as3, sgns3, s32, pwas3, pw3as3
      common /fssk/sstci(8, 8), sstcp(8, 8)
      common /fsth/maksi, maksp
      logical maksi, maksp

      siip = 0.
      it1p = 2*it1 + 1
      it2p = 2*it2 + 2
      it12p = 2*(it1+it2+2)
      bsp = rms(1, it1p+1)*rms(2, it2p+1)/(sq2pi*rms(3,it12p))
      kk = 1
      do k = 1, kmax, 2
        xsj1 = -1.
        km1 = k - 1
        tt1 = 0.
        jm1 = 0
        jj2 = 1
        do j1 = 1, km1, 2
          jj1 = 2*jm1 + 1
          j1km = km1 - jj1
          if (j1km<0) go to 100
          ! S(2t3+1,2t2,2t1,j1) computation
          ! Gauss quadrature in table 70-b
          i1123j1 = it1 + it2 + it3 + jm1 + 2
          i2123j1 = 2*i1123j1 - 1
          tt = 0.
          do ig = 1, igaus
            ! Hermite functions
            base = co(ig, it1p)*sn(ig, it2p)/blam(ig, i1123j1)
            htm0 = hsint(ig, 2, i2123j1+1)
            htp0 = hsint(ig, 1, i2123j1+1)
            tt = tt + base*(htp0-htm0)
          end do
          if (.not. maksi) then
            ! s3pw(j1km+1)=as3**j1km
            stock = 2.*xsj1*s3pw(j1km+1)
            sstci(kk, jj2) = fpar(km1, jj1)*stock
            xsj1 = -xsj1
          end if
          tt1 = sstci(kk, jj2)*tt + tt1
          jj2 = jj2 + 1
          jm1 = jm1 + 1
        end do
        siip = siip + tt1*ck(k)
        kk = kk + 1
        ! enddo from k (k=1,kmax+1)
100     continue
      end do
      siip = siip*bsp
      maksi = .true.
      return
    end function siip
    ! *******************************************************************
    ! FUNCTION sipi(it1,it2,it3)
    ! part of W**(2t3+1,2t2,2t1+1)     in table 61-b
    ! with S(2t3+1,2t2,2t1+1,j1) given in table 70-b
    ! *******************************************************************
    function sipi(it1, it2, it3)
      implicit real *8(a-h, o-z)
      common /consta/vl, pi, xmat, rpel, qst
      common /randu/ck(15), kmax
      common /gauss1/absg(40), wg(40), igaus
      common /circu/co(40, 50), sn(40, 50), blam(40, 100)
      common /rms/rms(3, 50), s1, s2, s3
      common /comtab/hsint(40, 2, 60), sqblam(40), s3pw(15)
      common /const/pi2, sqpi, pwtpi, sqpi2, sq2pi
      common /cars3/exs3, exs2, exs1, as3, sgns3, s32, pwas3, pw3as3
      common /fssk/sstci(8, 8), sstcp(8, 8)
      common /fsth/maksi, maksp
      logical maksi, maksp

      sipi = 0.
      it1p = 2*it1 + 2
      it2p = 2*it2 + 1
      it12p = 2*(it1+it2+2)
      bsp = rms(1, it1p+1)*rms(2, it2p+1)/(sq2pi*rms(3,it12p))
      kk = 1
      do k = 1, kmax, 2
        xsj1 = -1.
        km1 = k - 1
        tt1 = 0.
        jm1 = 0
        jj2 = 1
        do j1 = 1, km1, 2
          jj1 = 2*jm1 + 1
          j1km = km1 - jj1
          if (j1km<0) go to 100
          ! S(2t3+1,2t2,2t1,j1) computation
          ! Gauss quadrature in table 70-b
          i1123j1 = it1 + it2 + it3 + jm1 + 2
          i2123j1 = 2*i1123j1 - 1
          tt = 0.
          do ig = 1, igaus
            ! Hermite functions
            base = co(ig, it1p)*sn(ig, it2p)/blam(ig, i1123j1)
            htm0 = hsint(ig, 2, i2123j1+1)
            htp0 = hsint(ig, 1, i2123j1+1)
            tt = tt + base*(htp0+htm0)
          end do
          if (.not. maksi) then
            ! s3pw(j1km+1)=as3**j1km
            stock = 2.*xsj1*s3pw(j1km+1)
            sstci(kk, jj2) = fpar(km1, jj1)*stock
            xsj1 = -xsj1
          end if
          tt1 = sstci(kk, jj2)*tt + tt1
          jj2 = jj2 + 1
          jm1 = jm1 + 1
        end do
        sipi = sipi + tt1*ck(k)
        kk = kk + 1
        ! enddo from k (k=1,kmax+1)
100     continue
      end do
      sipi = sipi*bsp
      maksi = .true.
      return
    end function sipi
    ! *******************************************************************
    ! FUNCTION siii(it1,it2,it3)
    ! part of W**(2t3+1,2t2+1,2t1+1) in table 61-b
    ! with S(2t3+1,2t2+1,2t1+1,j1)   in table 70-b
    ! *******************************************************************
    function siii(it1, it2, it3)
      implicit real *8(a-h, o-z)
      common /consta/vl, pi, xmat, rpel, qst
      common /randu/ck(15), kmax
      common /gauss1/absg(40), wg(40), igaus
      common /circu/co(40, 50), sn(40, 50), blam(40, 100)
      common /rms/rms(3, 50), s1, s2, s3
      common /comtab/hsint(40, 2, 60), sqblam(40), s3pw(15)
      common /const/pi2, sqpi, pwtpi, sqpi2, sq2pi
      common /cars3/exs3, exs2, exs1, as3, sgns3, s32, pwas3, pw3as3
      common /fssk/sstci(8, 8), sstcp(8, 8)
      common /fsth/maksi, maksp
      logical maksi, maksp

      siii = 0.
      it1p = 2*it1 + 2
      it2p = 2*it2 + 2
      it12p = 2*(it1+it2+2) + 1
      bsp = rms(1, it1p+1)*rms(2, it2p+1)/(sq2pi*rms(3,it12p))
      kk = 1
      do k = 1, kmax, 2
        xsj1 = -1.
        km1 = k - 1
        tt1 = 0.
        jm1 = 0
        jj2 = 1
        do j1 = 1, km1, 2
          jj1 = 2*jm1 + 1
          j1km = km1 - jj1
          if (j1km<0) go to 100
          ! S(2t3+1,2t2,2t1,j1) computation
          ! Gauss quadrature in table 70-b
          i1123j1 = it1 + it2 + it3 + jm1 + 2
          i2123j1 = 2*i1123j1
          tt = 0.
          do ig = 1, igaus
            ! Hermite functions
            base = co(ig, it1p)*sn(ig, it2p)/blam(ig, i1123j1)
            htm0 = hsint(ig, 2, i2123j1+1)
            htp0 = hsint(ig, 1, i2123j1+1)
            tt = tt + base*(htm0-htp0)/sqblam(ig)
          end do
          if (.not. maksi) then
            ! s3pw(j1km+1)=as3**j1km
            stock = 2.*xsj1*s3pw(j1km+1)
            sstci(kk, jj2) = fpar(km1, jj1)*stock
            xsj1 = -xsj1
          end if
          tt1 = sstci(kk, jj2)*tt + tt1
          jj2 = jj2 + 1
          jm1 = jm1 + 1
        end do
        siii = siii + tt1*ck(k)
        ! enddo from k (k=1,kmax+1)
        kk = kk + 1
100     continue
      end do
      siii = -siii*bsp
      maksi = .true.
      return
    end function siii
    ! *******************************************************************
    ! FUNCTION sppp(it1,it2,it3)
    ! part of W**(2t3,2t2,2t1)     in table 61-a
    ! with S(2t3,2t2,2t1,j1) given in table 70-a
    ! *******************************************************************
    function sppp(it1, it2, it3)
      implicit real *8(a-h, o-z)
      common /consta/vl, pi, xmat, rpel, qst
      common /randu/ck(15), kmax
      common /gauss1/absg(40), wg(40), igaus
      common /circu/co(40, 50), sn(40, 50), blam(40, 100)
      common /rms/rms(3, 50), s1, s2, s3
      common /comtab/hsint(40, 2, 60), sqblam(40), s3pw(15)
      common /const/pi2, sqpi, pwtpi, sqpi2, sq2pi
      common /cars3/exs3, exs2, exs1, as3, sgns3, s32, pwas3, pw3as3
      common /fssk/sstci(8, 8), sstcp(8, 8)
      common /fsth/maksi, maksp
      logical maksi, maksp

      sppp = 0.
      it1p = 2*it1 + 1
      it2p = 2*it2 + 1
      it12p = 2*(it1+it2+1) + 1
      bsp = rms(1, it1p+1)*rms(2, it2p+1)/(sq2pi*rms(3,it12p))
      kk = 1
      do k = 1, kmax, 2
        km1 = k - 1
        xsj1 = 1
        tt1 = 0.
        jj1 = 1
        do j1 = 1, k
          jm1 = j1 - 1
          j1km = km1 - 2*jm1
          if (j1km<0) go to 100
          ! j1km must be always greather or equal to zero
          ! Gauss quadrature in table 70-a
          i1123j1 = it1 + it2 + it3 + jm1
          i2123j1 = 2*i1123j1
          tt = 0.
          do ig = 1, igaus
            ! Hermite functions
            base = co(ig, it1p)*sn(ig, it2p)/blam(ig, i1123j1)
            htm0 = hsint(ig, 2, i2123j1+1)
            htp0 = hsint(ig, 1, i2123j1+1)
            tt = tt + base*(htm0+htp0)/sqblam(ig)
          end do
          if (.not. maksp) then
            ! s3pw(j1km+1)=as3**j1km
            stock = 2.*xsj1*s3pw(j1km+1)
            sstcp(kk, jj1) = fpar(km1, 2*jm1)*stock
            xsj1 = -xsj1
          end if
          tt1 = sstcp(kk, jj1)*tt + tt1
          ! enddo from  j1
          jj1 = jj1 + 1
        end do
100     continue
        sppp = sppp + tt1*ck(k)
        ! enddo from k (k=1,kmax+1)
        kk = kk + 1
      end do
      sppp = sppp*bsp
      maksp = .true.
      return
    end function sppp
    ! *******************************************************************
    ! FUNCTION spip(it1,it2,it3)
    ! part of W**(2t3,2t2,2t1+1)     in table 61-a
    ! with S(2t3,2t2,2t1+1,j1) given in table 70-a
    ! *******************************************************************
    function spip(it1, it2, it3)
      implicit real *8(a-h, o-z)
      common /consta/vl, pi, xmat, rpel, qst
      common /randu/ck(15), kmax
      common /gauss1/absg(40), wg(40), igaus
      common /circu/co(40, 50), sn(40, 50), blam(40, 100)
      common /rms/rms(3, 50), s1, s2, s3
      common /comtab/hsint(40, 2, 60), sqblam(40), s3pw(15)
      common /const/pi2, sqpi, pwtpi, sqpi2, sq2pi
      common /cars3/exs3, exs2, exs1, as3, sgns3, s32, pwas3, pw3as3
      common /fssk/sstci(8, 8), sstcp(8, 8)
      common /fsth/maksi, maksp
      logical maksi, maksp

      spip = 0.
      it1p = 2*it1 + 1
      it2p = 2*it2 + 2
      it12p = 2*(it1+it2+1) + 2
      bsp = rms(1, it1p+1)*rms(2, it2p+1)/(sq2pi*rms(3,it12p))
      kk = 1
      do k = 1, kmax, 2
        km1 = k - 1
        xsj1 = 1
        tt1 = 0.
        jj1 = 1
        do j1 = 1, k
          jm1 = j1 - 1
          j1km = km1 - 2*jm1
          if (j1km<0) go to 100
          ! j1km must be always greather or equal to zero
          ! Gauss quadrature in table 70-a
          i1123j1 = it1 + it2 + it3 + jm1
          i2123j1 = 2*i1123j1 + 1
          tt = 0.
          do ig = 1, igaus
            ! Hermite functions
            base = co(ig, it1p)*sn(ig, it2p)/blam(ig, i1123j1+1)
            htm0 = hsint(ig, 2, i2123j1+1)
            htp0 = hsint(ig, 1, i2123j1+1)
            tt = tt + base*(htp0-htm0)
          end do
          if (.not. maksp) then
            ! s3pw(j1km+1)=as3**j1km
            stock = 2.*xsj1*s3pw(j1km+1)
            sstcp(kk, jj1) = fpar(km1, 2*jm1)*stock
            xsj1 = -xsj1
          end if
          tt1 = sstcp(kk, jj1)*tt + tt1
          ! enddo from  j1
          jj1 = jj1 + 1
        end do
100     continue
        spip = spip + tt1*ck(k)
        kk = kk + 1
        ! enddo from k (k=1,kmax+1)
      end do
      spip = spip*bsp
      maksp = .true.
      return
    end function spip
    ! *******************************************************************
    ! FUNCTION sppi(it1,it2,it3)
    ! part of W**(2t3,2t2,2t1+1)     in table 61-a
    ! with S(2t3,2t2,2t1+1,j1) given in table 70-a
    ! *******************************************************************
    function sppi(it1, it2, it3)
      implicit real *8(a-h, o-z)
      common /consta/vl, pi, xmat, rpel, qst
      common /randu/ck(15), kmax
      common /gauss1/absg(40), wg(40), igaus
      common /circu/co(40, 50), sn(40, 50), blam(40, 100)
      common /rms/rms(3, 50), s1, s2, s3
      common /comtab/hsint(40, 2, 60), sqblam(40), s3pw(15)
      common /const/pi2, sqpi, pwtpi, sqpi2, sq2pi
      common /cars3/exs3, exs2, exs1, as3, sgns3, s32, pwas3, pw3as3
      common /fssk/sstci(8, 8), sstcp(8, 8)
      common /fsth/maksi, maksp
      logical maksi, maksp

      sppi = 0.
      it1p = 2*it1 + 2
      it2p = 2*it2 + 1
      it12p = 2*(it1+it2+1) + 2
      bsp = rms(1, it1p+1)*rms(2, it2p+1)/(sq2pi*rms(3,it12p))
      kk = 1
      do k = 1, kmax, 2
        km1 = k - 1
        xsj1 = 1.
        tt1 = 0.
        jj1 = 1
        do j1 = 1, k
          jm1 = j1 - 1
          j1km = km1 - 2*jm1
          ! j1km must be always greather or equal to zero
          if (j1km<0) go to 100
          ! Gauss quadrature in table 70-a
          i1123j1 = it1 + it2 + it3 + jm1
          i2123j1 = 2*i1123j1 + 1
          tt = 0.
          do ig = 1, igaus
            ! Hermite functions
            base = co(ig, it1p)*sn(ig, it2p)/blam(ig, i1123j1+1)
            htm0 = hsint(ig, 2, i2123j1+1)
            htp0 = hsint(ig, 1, i2123j1+1)
            tt = tt + base*(htm0+htp0)
          end do
          if (.not. maksp) then
            ! s3pw(j1km+1)=as3**j1km
            stock = 2.*xsj1*s3pw(j1km+1)
            sstcp(kk, jj1) = fpar(km1, 2*jm1)*stock
            xsj1 = -xsj1
          end if
          tt1 = sstcp(kk, jj1)*tt + tt1
          ! enddo from  j1
          jj1 = jj1 + 1
        end do
100     continue
        sppi = sppi + tt1*ck(k)
        ! enddo from k (k=1,kmax+1)
        kk = kk + 1
      end do
      sppi = sppi*bsp
      maksp = .true.
      return
    end function sppi
    ! *******************************************************************
    ! FUNCTION spii(it1,it2,it3)
    ! part of W**(2t3,2t2,2t1+1)       in table 61-a
    ! with S(2t3,2t2+1,2t1+1,j1) given in table 70-a
    ! *******************************************************************
    function spii(it1, it2, it3)
      implicit real *8(a-h, o-z)
      common /consta/vl, pi, xmat, rpel, qst
      common /randu/ck(15), kmax
      common /gauss1/absg(40), wg(40), igaus
      common /circu/co(40, 50), sn(40, 50), blam(40, 100)
      common /rms/rms(3, 50), s1, s2, s3
      common /comtab/hsint(40, 2, 60), sqblam(40), s3pw(15)
      common /const/pi2, sqpi, pwtpi, sqpi2, sq2pi
      common /cars3/exs3, exs2, exs1, as3, sgns3, s32, pwas3, pw3as3
      common /fssk/sstci(8, 8), sstcp(8, 8)
      common /fsth/maksi, maksp
      logical maksi, maksp

      spii = 0.
      it1p = 2*it1 + 2
      it2p = 2*it2 + 2
      it12p = 2*(it1+it2+2) + 1
      bsp = rms(1, it1p+1)*rms(2, it2p+1)/(sq2pi*rms(3,it12p))
      kk = 1
      do k = 1, kmax, 2
        km1 = k - 1
        xsj1 = 1.
        tt1 = 0.
        jj1 = 1
        do j1 = 1, k
          jm1 = j1 - 1
          j1km = km1 - 2*jm1
          if (j1km<0) go to 100
          ! j1km must be always greather or equal to zero
          ! Gauss quadrature in table 70-a
          i1123j1 = it1 + it2 + it3 + jm1
          i2123j1 = 2*i1123j1 + 2
          tt = 0.
          do ig = 1, igaus
            ! Hermite functions
            base = co(ig, it1p)*sn(ig, it2p)/blam(ig, i1123j1+1)
            htm0 = hsint(ig, 2, i2123j1+1)
            htp0 = hsint(ig, 1, i2123j1+1)
            tt = tt + base*(htm0-htp0)/sqblam(ig)
          end do
          if (.not. maksp) then
            ! s3pw(j1km+1)=as3**j1km
            stock = 2.*xsj1*s3pw(j1km+1)
            sstcp(kk, jj1) = fpar(km1, 2*jm1)*stock
            xsj1 = -xsj1
          end if
          tt1 = sstcp(kk, jj1)*tt + tt1
          ! enddo from  j1
          jj1 = jj1 + 1
        end do
100     continue
        spii = spii + tt1*ck(k)
        kk = kk + 1
        ! enddo from k (k=1,kmax+1)
      end do
      maksp = .true.
      spii = -spii*bsp
      return
    end function spii
    ! ****************************************************************
    ! funtions sigma in table 14
    ! these functions are used in tables 77-a-1 to 77-b-2
    ! sgppp -->l,m and n even
    ! sgpip --> l even, m odd, n even
    ! .................................
    ! *****************************************************************
    ! *******************************************************************
    ! FUNCTION sgppp(it1,it2,it3)
    ! FUNCTION sigma(2t3,2t2,2t1) in table 14
    ! in E(2t3,2t2,2t1)           in table 77-a-1
    ! *******************************************************************
    function sgppp(it1, it2, it3)
      implicit real *8(a-h, o-z)
      common /rms/rms(3, 50), s1, s2, s3
      common /herfun/hs1(60), hs2(60), hs3(60)
      common /cars3/exs3, exs2, exs1, as3, sgns3, s32, pwas3, pw3as3
      common /sgsk/sgp3(30), sgi3(30), sgrp(30, 30), sgri(30, 30)
      common /sgpth/mksgi, mksgp
      logical mksgi, mksgp

      sgppp = 0.
      if (it3==0) return
      sgn = -1.
      if (.not. mksgp) then
        mksgp = .true.
        do ik = 1, it3
          sg1 = 0.
          km2 = 2*ik - 2
          it3kp1 = it3 - ik + 1
          it3k = 2*(it3-ik)
          sgp3(ik) = sgn*hs3(km2+1)*rms(3, it3k+1)
          do jk = 1, it3kp1
            jkm1 = jk - 1
            jt3kj = 2*(it3-ik-jkm1)
            jt23kj = 2*(it3+it2-ik-jkm1)
            jt1j = 2*(it1+jkm1)
            stoc = rms(1, 2*jkm1+1)*rms(2, jt3kj+1)
            sgrp(ik, jk) = fpar(it3-ik, jkm1)/stoc
            sg1 = sg1 + sgrp(ik, jk)*hs2(jt23kj+1)*hs1(jt1j+1)
          end do
          sgppp = sgppp + sgp3(ik)*sg1
          sgn = -sgn
        end do
        return
      else
        do ik = 1, it3
          sg1 = 0.
          it3kp1 = it3 - ik + 1
          do jk = 1, it3kp1
            jkm1 = jk - 1
            jt23kj = 2*(it3+it2-ik-jkm1)
            jt1j = 2*(it1+jkm1)
            sg1 = sg1 + sgrp(ik, jk)*hs2(jt23kj+1)*hs1(jt1j+1)
          end do
          sgppp = sgppp + sgp3(ik)*sg1
        end do
        return
      end if
    end function sgppp
    ! *******************************************************************
    ! FUNCTION sgpip(it1,it2,it3)
    ! FUNCTION sigma(2t3,2t+1,2t1) in table 14
    ! is in E(2t3,2t2+1,2t1) given in table 77-a-2
    ! *******************************************************************
    function sgpip(it1, it2, it3)
      implicit real *8(a-h, o-z)
      common /rms/rms(3, 50), s1, s2, s3
      common /herfun/hs1(60), hs2(60), hs3(60)
      common /cars3/exs3, exs2, exs1, as3, sgns3, s32, pwas3, pw3as3
      common /sgsk/sgp3(30), sgi3(30), sgrp(30, 30), sgri(30, 30)
      common /sgpth/mksgi, mksgp
      logical mksgi, mksgp

      sgpip = 0.
      if (it3==0) return
      sgn = -1.
      if (.not. mksgp) then
        mksgp = .true.
        do ik = 1, it3
          sg1 = 0.
          km2 = 2*ik - 2
          it3kp1 = it3 - ik + 1
          it3k = 2*(it3-ik)
          ! omment             hs30=hs3(km2+1)*rms(3,it3k+1)
          sgp3(ik) = sgn*hs3(km2+1)*rms(3, it3k+1)
          do jk = 1, it3kp1
            jkm1 = jk - 1
            jt3kj = 2*(it3-ik-jkm1)
            jt23kj = 2*(it3+it2-ik-jkm1)
            jt1j = 2*(it1+jkm1)
            stoc = rms(1, 2*jkm1+1)*rms(2, jt3kj+1)
            sgrp(ik, jk) = fpar(it3-ik, jkm1)/stoc
            sg1 = sg1 + sgrp(ik, jk)*hs2(jt23kj+2)*hs1(jt1j+1)
          end do
          sgpip = sgpip + sgp3(ik)*sg1
          sgn = -sgn
        end do
        return
      else
        do ik = 1, it3
          sg1 = 0.
          it3kp1 = it3 - ik + 1
          do jk = 1, it3kp1
            jkm1 = jk - 1
            jt23kj = 2*(it3+it2-ik-jkm1)
            jt1j = 2*(it1+jkm1)
            sg1 = sg1 + sgrp(ik, jk)*hs2(jt23kj+2)*hs1(jt1j+1)
          end do
          sgpip = sgpip + sgp3(ik)*sg1
        end do
        return
      end if
    end function sgpip
    ! *******************************************************************
    ! FUNCTION sgppi(it1,it2,it3)
    ! FUNCTION sigma(2t3,2t2,2t1+1) in table 14
    ! is in E(2t3,2t2,2t1+1)        in table 77-a-2
    ! *******************************************************************
    function sgppi(it1, it2, it3)
      implicit real *8(a-h, o-z)
      common /rms/rms(3, 50), s1, s2, s3
      common /herfun/hs1(60), hs2(60), hs3(60)
      common /cars3/exs3, exs2, exs1, as3, sgns3, s32, pwas3, pw3as3
      common /sgsk/sgp3(30), sgi3(30), sgrp(30, 30), sgri(30, 30)
      common /sgpth/mksgi, mksgp
      logical mksgi, mksgp

      sgppi = 0.
      if (it3==0) return
      sgn = -1.
      if (.not. mksgp) then
        mksgp = .true.
        do ik = 1, it3
          sg1 = 0.
          km2 = 2*ik - 2
          it3kp1 = it3 - ik + 1
          it3k = 2*(it3-ik)
          sgp3(ik) = sgn*hs3(km2+1)*rms(3, it3k+1)
          do jk = 1, it3kp1
            jkm1 = jk - 1
            jt3kj = 2*(it3-ik-jkm1)
            jt23kj = 2*(it3+it2-ik-jkm1)
            jt1j = 2*(it1+jkm1)
            stoc = rms(1, 2*jkm1+1)*rms(2, jt3kj+1)
            sgrp(ik, jk) = fpar(it3-ik, jkm1)/stoc
            sg1 = sg1 + sgrp(ik, jk)*hs2(jt23kj+1)*hs1(jt1j+2)
          end do
          sgppi = sgppi + sgp3(ik)*sg1
          sgn = -sgn
        end do
        return
      else
        do ik = 1, it3
          sg1 = 0.
          it3kp1 = it3 - ik + 1
          do jk = 1, it3kp1
            jkm1 = jk - 1
            jt23kj = 2*(it3+it2-ik-jkm1)
            jt1j = 2*(it1+jkm1)
            sg1 = sg1 + sgrp(ik, jk)*hs2(jt23kj+1)*hs1(jt1j+2)
          end do
          sgppi = sgppi + sgp3(ik)*sg1
        end do
        return
      end if
    end function sgppi
    ! *******************************************************************
    ! FUNCTION sgpii(it1,it2,it3)
    ! FUNCTION sigma(2t3,2t2+1,2t1+1)  in table 14
    ! correspond to E(2t3,2t2+1,2t1+1) in table 77-a-1
    ! *******************************************************************
    function sgpii(it1, it2, it3)
      implicit real *8(a-h, o-z)
      common /rms/rms(3, 50), s1, s2, s3
      common /herfun/hs1(60), hs2(60), hs3(60)
      common /cars3/exs3, exs2, exs1, as3, sgns3, s32, pwas3, pw3as3
      common /sgsk/sgp3(30), sgi3(30), sgrp(30, 30), sgri(30, 30)
      common /sgpth/mksgi, mksgp
      logical mksgi, mksgp

      sgpii = 0.
      if (it3==0) return
      sgn = -1.
      if (.not. mksgp) then
        mksgp = .true.
        do ik = 1, it3
          sg1 = 0.
          km2 = 2*ik - 2
          it3kp1 = it3 - ik + 1
          it3k = 2*(it3-ik)
          sgp3(ik) = sgn*hs3(km2+1)*rms(3, it3k+1)
          do jk = 1, it3kp1
            jkm1 = jk - 1
            jt3kj = 2*(it3-ik-jkm1)
            jt23kj = 2*(it3+it2-ik-jkm1)
            jt1j = 2*(it1+jkm1)
            stoc = rms(1, 2*jkm1+1)*rms(2, jt3kj+1)
            sgrp(ik, jk) = fpar(it3-ik, jkm1)/stoc
            sg1 = sg1 + sgrp(ik, jk)*hs2(jt23kj+2)*hs1(jt1j+2)
          end do
          sgpii = sgpii + sgp3(ik)*sg1
          sgn = -sgn
        end do
        return
      else
        do ik = 1, it3
          sg1 = 0.
          it3kp1 = it3 - ik + 1
          do jk = 1, it3kp1
            jkm1 = jk - 1
            jt23kj = 2*(it3+it2-ik-jkm1)
            jt1j = 2*(it1+jkm1)
            sg1 = sg1 + sgrp(ik, jk)*hs2(jt23kj+2)*hs1(jt1j+2)
          end do
          sgpii = sgpii + sgp3(ik)*sg1
        end do
        return
      end if
    end function sgpii
    ! *******************************************************************
    ! FUNCTION sgipp(it1,it2,it3)
    ! FUNCTION sigma(2t3+1,2t2,2t1) in table 14
    ! E(2t3+1,2t2,2t1)     is given in table 77-b-2
    ! *******************************************************************
    function sgipp(it1, it2, it3)
      implicit real *8(a-h, o-z)
      common /rms/rms(3, 50), s1, s2, s3
      common /herfun/hs1(60), hs2(60), hs3(60)
      common /cars3/exs3, exs2, exs1, as3, sgns3, s32, pwas3, pw3as3
      common /sgsk/sgp3(30), sgi3(30), sgrp(30, 30), sgri(30, 30)
      common /sgpth/mksgi, mksgp
      logical mksgi, mksgp

      sgipp = 0.
      if (it3<=0) return
      sgn = -1.
      if (.not. mksgi) then
        mksgi = .true.
        do ik = 1, it3
          sg1 = 0.
          km1 = 2*ik - 1
          it3kp1 = it3 - ik + 1
          it3k = 2*(it3-ik)
          sgi3(ik) = sgn*hs3(km1+1)*rms(3, it3k+1)
          do jk = 1, it3kp1
            jkm1 = jk - 1
            jt3kj = 2*(it3-ik-jkm1)
            jt23kj = 2*(it3+it2-ik-jkm1)
            jt1j = 2*(it1+jkm1)
            stoc = rms(1, 2*jkm1+1)*rms(2, jt3kj+1)
            sgri(ik, jk) = fpar(it3-ik, jkm1)/stoc
            sg1 = sg1 + sgri(ik, jk)*hs2(jt23kj+1)*hs1(jt1j+1)
          end do
          sgipp = sgipp + sgi3(ik)*sg1
          sgn = -sgn
        end do
        return
      else
        do ik = 1, it3
          sg1 = 0.
          it3kp1 = it3 - ik + 1
          do jk = 1, it3kp1
            jkm1 = jk - 1
            jt23kj = 2*(it3+it2-ik-jkm1)
            jt1j = 2*(it1+jkm1)
            sg1 = sg1 + sgri(ik, jk)*hs2(jt23kj+1)*hs1(jt1j+1)
          end do
          sgipp = sgipp + sgi3(ik)*sg1
        end do
        return
      end if
    end function sgipp
    ! *******************************************************************
    ! FUNCTION sgiip(it1,it2,it3)
    ! FUNCTION sigma(2t3+1,2t2+1,2t1) in table 14
    ! inside E(2t3+1,2t2+1,2t1) given in table 77-b-1
    ! *******************************************************************
    function sgiip(it1, it2, it3)
      implicit real *8(a-h, o-z)
      common /rms/rms(3, 50), s1, s2, s3
      common /herfun/hs1(60), hs2(60), hs3(60)
      common /cars3/exs3, exs2, exs1, as3, sgns3, s32, pwas3, pw3as3
      common /sgsk/sgp3(30), sgi3(30), sgrp(30, 30), sgri(30, 30)
      common /sgpth/mksgi, mksgp
      logical mksgi, mksgp

      sgiip = 0.
      if (it3==0) return
      sgn = -1.
      if (.not. mksgi) then
        mksgi = .true.
        do ik = 1, it3
          sg1 = 0.
          km1 = 2*ik - 1
          it3kp1 = it3 - ik + 1
          it3k = 2*(it3-ik)
          sgi3(ik) = sgn*hs3(km1+1)*rms(3, it3k+1)
          do jk = 1, it3kp1
            jkm1 = jk - 1
            jt3kj = 2*(it3-ik-jkm1)
            jt23kj = 2*(it3+it2-ik-jkm1)
            jt1j = 2*(it1+jkm1)
            stoc = rms(1, 2*jkm1+1)*rms(2, jt3kj+1)
            sgri(ik, jk) = fpar(it3-ik, jkm1)/stoc
            sg1 = sg1 + sgri(ik, jk)*hs2(jt23kj+2)*hs1(jt1j+1)
          end do
          sgiip = sgiip + sgi3(ik)*sg1
          sgn = -sgn
        end do
        return
      else
        do ik = 1, it3
          sg1 = 0.
          it3kp1 = it3 - ik + 1
          do jk = 1, it3kp1
            jkm1 = jk - 1
            jt23kj = 2*(it3+it2-ik-jkm1)
            jt1j = 2*(it1+jkm1)
            sg1 = sg1 + sgri(ik, jk)*hs2(jt23kj+2)*hs1(jt1j+1)
          end do
          sgiip = sgiip + sgi3(ik)*sg1
        end do
        return
      end if
    end function sgiip
    ! *******************************************************************
    ! FUNCTION sgipi(it1,it2,it3)
    ! FUNCTION sigma(2t3+1,2t2,2t1+1)  in table 14
    ! in E(2t3+1,2t2,2t1+1)            in table 77-b-1
    ! *******************************************************************
    function sgipi(it1, it2, it3)
      implicit real *8(a-h, o-z)
      common /rms/rms(3, 50), s1, s2, s3
      common /herfun/hs1(60), hs2(60), hs3(60)
      common /cars3/exs3, exs2, exs1, as3, sgns3, s32, pwas3, pw3as3
      common /sgsk/sgp3(30), sgi3(30), sgrp(30, 30), sgri(30, 30)
      common /sgpth/mksgi, mksgp
      logical mksgi, mksgp

      sgipi = 0.
      if (it3==0) return
      sgn = -1.
      if (.not. mksgi) then
        mksgi = .true.
        do ik = 1, it3
          sg1 = 0.
          km1 = 2*ik - 1
          it3kp1 = it3 - ik + 1
          it3k = 2*(it3-ik)
          sgi3(ik) = sgn*hs3(km1+1)*rms(3, it3k+1)
          do jk = 1, it3kp1
            jkm1 = jk - 1
            jt3kj = 2*(it3-ik-jkm1)
            jt23kj = 2*(it3+it2-ik-jkm1)
            jt1j = 2*(it1+jkm1)
            stoc = rms(1, 2*jkm1+1)*rms(2, jt3kj+1)
            sgri(ik, jk) = fpar(it3-ik, jkm1)/stoc
            sg1 = sg1 + sgri(ik, jk)*hs2(jt23kj+1)*hs1(jt1j+2)
          end do
          sgipi = sgipi + sgi3(ik)*sg1
          sgn = -sgn
        end do
        return
      else
        do ik = 1, it3
          sg1 = 0.
          it3kp1 = it3 - ik + 1
          do jk = 1, it3kp1
            jkm1 = jk - 1
            jt23kj = 2*(it3+it2-ik-jkm1)
            jt1j = 2*(it1+jkm1)
            sg1 = sg1 + sgri(ik, jk)*hs2(jt23kj+1)*hs1(jt1j+2)
          end do
          sgipi = sgipi + sgi3(ik)*sg1
        end do
        return
      end if
    end function sgipi
    ! *******************************************************************
    ! FUNCTION sgiii(it1,it2,it3)
    ! FUNCTION sigma(2t3+1,2t2+1,2t1+1) in table 14
    ! in E(2t3+1,2t2+1,2t1+1)           in table 77-b-2
    ! *******************************************************************
    function sgiii(it1, it2, it3)
      implicit real *8(a-h, o-z)
      common /rms/rms(3, 50), s1, s2, s3
      common /herfun/hs1(60), hs2(60), hs3(60)
      common /cars3/exs3, exs2, exs1, as3, sgns3, s32, pwas3, pw3as3
      common /sgsk/sgp3(30), sgi3(30), sgrp(30, 30), sgri(30, 30)
      common /sgpth/mksgi, mksgp
      logical mksgi, mksgp

      sgiii = 0.
      if (it3==0) return
      sgn = -1.
      if (.not. mksgi) then
        mksgi = .true.
        do ik = 1, it3
          sg1 = 0.
          km1 = 2*ik - 1
          it3kp1 = it3 - ik + 1
          it3k = 2*(it3-ik)
          sgi3(ik) = sgn*hs3(km1+1)*rms(3, it3k+1)
          do jk = 1, it3kp1
            jkm1 = jk - 1
            jt3kj = 2*(it3-ik-jkm1)
            jt23kj = 2*(it3+it2-ik-jkm1)
            jt1j = 2*(it1+jkm1)
            stoc = rms(1, 2*jkm1+1)*rms(2, jt3kj+1)
            sgri(ik, jk) = fpar(it3-ik, jkm1)/stoc
            sg1 = sg1 + sgri(ik, jk)*hs2(jt23kj+2)*hs1(jt1j+2)
          end do
          sgiii = sgiii + sgi3(ik)*sg1
          sgn = -sgn
        end do
        return
      else
        do ik = 1, it3
          sg1 = 0.
          it3kp1 = it3 - ik + 1
          do jk = 1, it3kp1
            jkm1 = jk - 1
            jt23kj = 2*(it3+it2-ik-jkm1)
            jt1j = 2*(it1+jkm1)
            sg1 = sg1 + sgri(ik, jk)*hs2(jt23kj+2)*hs1(jt1j+2)
          end do
          sgiii = sgiii + sgi3(ik)*sg1
        end do
        return
      end if
    end function sgiii
    ! *****************************************************************************
    ! Functions U and V given in tables 75 and 76
    ! uppp ---> l,m,n  even
    ! upip ---> l even, m odd, n even
    ! .................................
    ! *****************************************************************************
    ! *******************************************************************
    ! FUNCTION uppp(it1,it2,it3)
    ! the integral U(2t3,2t2,2t1,thet) is given in table 75
    ! the summation with cos(thet)**2*t1,cos(thet)**2*t2 is found in
    ! table 77-a-1
    ! *******************************************************************
    function uppp(it1, it2, it3)
      implicit real *8(a-h, o-z)
      common /rms/rms(3, 50), s1, s2, s3
      common /gauss1/absg(40), wg(40), igaus
      common /circu/co(40, 50), sn(40, 50), blam(40, 100)
      common /uvtab/epsi1(40, 40), epsi2(40, 40), akpcc(40, 40), akpcs(40, 40), akpsc(40, 40), akpss(40, 40)
      common /expmod/ragp(40, 100), ragm1(40, 40)
      common /uvint/arcc(40, 40), arcs(40, 40), arsc(40, 40), arss(40, 40), cs(40)

      uppp = 0.
      ind = 2*(it1+it2+it3) + 1
      idt1 = 2*it1 + 1
      idt2 = 2*it2 + 1
      do j = 1, igaus
        cs(j) = co(j, idt1)*sn(j, idt2)*wg(j)
        u = 0.
        do i = 1, igaus
          arcc(i, j) = ragp(i, ind)*akpcc(i, j)
          u = u + arcc(i, j)*epsi1(i, j)
        end do
        uppp = uppp + cs(j)*u
      end do
      return
    end function uppp
    ! *******************************************************************
    ! FUNCTION upip(it1,it2,it3)
    ! the integral U(2t3,2t2+1,2t1,thet) is given in table 75
    ! the summation with cos(thet)**2t1,cos(thet)**(2t2+1) is in
    ! table 77-a-2
    ! *******************************************************************
    function upip(it1, it2, it3)
      implicit real *8(a-h, o-z)
      common /rms/rms(3, 50), s1, s2, s3
      common /gauss1/absg(40), wg(40), igaus
      common /circu/co(40, 50), sn(40, 50), blam(40, 100)
      common /uvtab/epsi1(40, 40), epsi2(40, 40), akpcc(40, 40), akpcs(40, 40), akpsc(40, 40), akpss(40, 40)
      common /expmod/ragp(40, 100), ragm1(40, 40)
      common /uvint/arcc(40, 40), arcs(40, 40), arsc(40, 40), arss(40, 40), cs(40)

      upip = 0.
      ind = 2*(it1+it2+it3) + 2
      idt1 = 2*it1 + 1
      idt2 = 2*it2 + 2
      do j = 1, igaus
        cs(j) = co(j, idt1)*sn(j, idt2)*wg(j)
        u = 0.
        do i = 1, igaus
          arcs(i, j) = ragp(i, ind)*akpcs(i, j)
          u = u + arcs(i, j)*epsi1(i, j)
        end do
        upip = upip + cs(j)*u
      end do
      return
    end function upip
    ! *******************************************************************
    ! FUNCTION uppi(it1,it2,it3)
    ! the integral U(2t3,2t2,2t1+1,thet)  in table 75
    ! the summation with cos(thet)**(2*t1+1),cos(thet)**2*t2  in
    ! table 77-a-2
    ! *******************************************************************
    function uppi(it1, it2, it3)
      implicit real *8(a-h, o-z)
      common /rms/rms(3, 50), s1, s2, s3
      common /gauss1/absg(40), wg(40), igaus
      common /circu/co(40, 50), sn(40, 50), blam(40, 100)
      common /uvtab/epsi1(40, 40), epsi2(40, 40), akpcc(40, 40), akpcs(40, 40), akpsc(40, 40), akpss(40, 40)
      common /expmod/ragp(40, 100), ragm1(40, 40)
      common /uvint/arcc(40, 40), arcs(40, 40), arsc(40, 40), arss(40, 40), cs(40)

      uppi = 0.
      ind = 2*(it1+it2+it3) + 2
      idt1 = 2*it1 + 2
      idt2 = 2*it2 + 1
      do j = 1, igaus
        cs(j) = co(j, idt1)*sn(j, idt2)*wg(j)
        u = 0.
        do i = 1, igaus
          arsc(i, j) = ragp(i, ind)*akpsc(i, j)
          u = u + arsc(i, j)*epsi1(i, j)
        end do
        uppi = uppi + cs(j)*u
      end do
      return
    end function uppi
    ! *******************************************************************
    ! FUNCTION upii(it1,it2,it3)
    ! the integral U(2*t3,2*t2+1,2*t1+1,thet)  table 75
    ! the summation with cos(thet)**(2*t1+1),cos(thet)**(2*t2+1)
    ! table 77-a-1
    ! *******************************************************************
    function upii(it1, it2, it3)
      implicit real *8(a-h, o-z)
      common /rms/rms(3, 50), s1, s2, s3
      common /gauss1/absg(40), wg(40), igaus
      common /circu/co(40, 50), sn(40, 50), blam(40, 100)
      common /uvtab/epsi1(40, 40), epsi2(40, 40), akpcc(40, 40), akpcs(40, 40), akpsc(40, 40), akpss(40, 40)
      common /expmod/ragp(40, 100), ragm1(40, 40)
      common /uvint/arcc(40, 40), arcs(40, 40), arsc(40, 40), arss(40, 40), cs(40)

      upii = 0.
      ind = 2*(it1+it2+it3+1) + 1
      idt1 = 2*it1 + 2
      idt2 = 2*it2 + 2
      do j = 1, igaus
        cs(j) = co(j, idt1)*sn(j, idt2)*wg(j)
        u = 0.
        do i = 1, igaus
          arss(i, j) = ragp(i, ind)*akpss(i, j)
          u = u + arss(i, j)*epsi1(i, j)
        end do
        upii = upii + cs(j)*u
      end do
      return
    end function upii
    ! *******************************************************************
    ! FUNCTION uipp(it1,it2,it3)
    ! the integral U(2*t3+1,2*t2,2*t1,thet)  table 75
    ! for the summation with cos(thet)**2*t1,cos(thet)**2*t2 see
    ! table 77-b-2
    ! *******************************************************************
    function uipp(it1, it2, it3)
      implicit real *8(a-h, o-z)
      common /rms/rms(3, 50), s1, s2, s3
      common /gauss1/absg(40), wg(40), igaus
      common /circu/co(40, 50), sn(40, 50), blam(40, 100)
      common /uvtab/epsi1(40, 40), epsi2(40, 40), akpcc(40, 40), akpcs(40, 40), akpsc(40, 40), akpss(40, 40)
      common /expmod/ragp(40, 100), ragm1(40, 40)
      common /uvint/arcc(40, 40), arcs(40, 40), arsc(40, 40), arss(40, 40), cs(40)

      uipp = 0.
      ind = 2*(it1+it2+it3+1)
      idt1 = 2*it1 + 1
      idt2 = 2*it2 + 1
      do j = 1, igaus
        cs(j) = co(j, idt1)*sn(j, idt2)*wg(j)
        u = 0.
        do i = 1, igaus
          arcc(i, j) = ragp(i, ind)*akpcc(i, j)
          u = u + arcc(i, j)*epsi1(i, j)
        end do
        uipp = uipp + cs(j)*u
      end do
      return
    end function uipp
    ! *******************************************************************
    ! FUNCTION uiip(it1,it2,it3)
    ! the integral U(2*t3+1,2*t2+1,2*t1,thet) table 75
    ! summation over cos(thet)**2*t1,cos(thet)**(2*t2+1) table 77-b-1
    ! *******************************************************************
    function uiip(it1, it2, it3)
      implicit real *8(a-h, o-z)
      common /rms/rms(3, 50), s1, s2, s3
      common /gauss1/absg(40), wg(40), igaus
      common /circu/co(40, 50), sn(40, 50), blam(40, 100)
      common /uvtab/epsi1(40, 40), epsi2(40, 40), akpcc(40, 40), akpcs(40, 40), akpsc(40, 40), akpss(40, 40)
      common /expmod/ragp(40, 100), ragm1(40, 40)
      common /uvint/arcc(40, 40), arcs(40, 40), arsc(40, 40), arss(40, 40), cs(40)

      uiip = 0.
      ind = 2*(it1+it2+it3+1) + 1
      idt1 = 2*it1 + 1
      idt2 = 2*it2 + 2
      do j = 1, igaus
        cs(j) = co(j, idt1)*sn(j, idt2)*wg(j)
        u = 0.
        do i = 1, igaus
          arcs(i, j) = ragp(i, ind)*akpcs(i, j)
          u = u + arcs(i, j)*epsi1(i, j)
        end do
        uiip = uiip + cs(j)*u
      end do
      return
    end function uiip
    ! *******************************************************************
    ! FUNCTION uipi(it1,it2,it3)
    ! the integral U(2t3+1,2t2,2t1+1,thet)  table 75
    ! summation over cos(thet)**(2*t1+1),cos(thet)**2*t2  table 77-b-1
    ! *******************************************************************
    function uipi(it1, it2, it3)
      implicit real *8(a-h, o-z)
      common /rms/rms(3, 50), s1, s2, s3
      common /gauss1/absg(40), wg(40), igaus
      common /circu/co(40, 50), sn(40, 50), blam(40, 100)
      common /uvtab/epsi1(40, 40), epsi2(40, 40), akpcc(40, 40), akpcs(40, 40), akpsc(40, 40), akpss(40, 40)
      common /expmod/ragp(40, 100), ragm1(40, 40)
      common /uvint/arcc(40, 40), arcs(40, 40), arsc(40, 40), arss(40, 40), cs(40)

      uipi = 0.
      ind = 2*(it1+it2+it3+1) + 1
      idt1 = 2*it1 + 2
      idt2 = 2*it2 + 1
      do j = 1, igaus
        cs(j) = co(j, idt1)*sn(j, idt2)*wg(j)
        u = 0.
        do i = 1, igaus
          arsc(i, j) = ragp(i, ind)*akpsc(i, j)
          u = u + arsc(i, j)*epsi1(i, j)
        end do
        uipi = uipi + cs(j)*u
      end do
      return
    end function uipi
    ! *******************************************************************
    ! FUNCTION uiii(it1,it2,it3)
    ! the integral U(2*t3+1,2*t2+1,2*t1+1,thet)  table 75
    ! summation with cos(thet)**(2*t1+1),cos(thet)**(2*t2+1)
    ! (see table 77-b-2)
    ! *******************************************************************
    function uiii(it1, it2, it3)
      implicit real *8(a-h, o-z)
      common /rms/rms(3, 50), s1, s2, s3
      common /gauss1/absg(40), wg(40), igaus
      common /circu/co(40, 50), sn(40, 50), blam(40, 100)
      common /uvtab/epsi1(40, 40), epsi2(40, 40), akpcc(40, 40), akpcs(40, 40), akpsc(40, 40), akpss(40, 40)
      common /expmod/ragp(40, 100), ragm1(40, 40)
      common /uvint/arcc(40, 40), arcs(40, 40), arsc(40, 40), arss(40, 40), cs(40)

      uiii = 0.
      ind = 2*(it1+it2+it3+1) + 2
      idt1 = 2*it1 + 2
      idt2 = 2*it2 + 2
      do j = 1, igaus
        cs(j) = co(j, idt1)*sn(j, idt2)*wg(j)
        u = 0.
        do i = 1, igaus
          arss(i, j) = ragp(i, ind)*akpss(i, j)
          u = u + arss(i, j)*epsi1(i, j)
        end do
        uiii = uiii + cs(j)*u
      end do
      return
    end function uiii
    ! *******************************************************************
    ! FUNCTION vppp(k)
    ! the integral V(2t3,2t2,2t1,k,thet)  table 76
    ! sum with cos(thet)**2*t1,cos(thet)**2*t2 (see table 77-a-1)
    ! *******************************************************************
    function vppp(k)
      implicit real *8(a-h, o-z)
      common /rms/rms(3, 50), s1, s2, s3
      common /gauss1/absg(40), wg(40), igaus
      common /circu/co(40, 50), sn(40, 50), blam(40, 100)
      common /uvtab/epsi1(40, 40), epsi2(40, 40), akpcc(40, 40), akpcs(40, 40), akpsc(40, 40), akpss(40, 40)
      common /expmod/ragp(40, 100), ragm1(40, 40)
      common /uvint/arcc(40, 40), arcs(40, 40), arsc(40, 40), arss(40, 40), cs(40)

      vppp = 0.
      do j = 1, igaus
        u = 0.
        do i = 1, igaus
          u = u + arcc(i, j)*ragm1(i, k)*epsi2(i, j)
        end do
        vppp = vppp + cs(j)*u
      end do
      return
    end function vppp
    ! *******************************************************************
    ! FUNCTION vpip(k)
    ! the integral V(2t3,2t2+1,2t1,k,thet)  table 76
    ! sum with cos(thet)**2*t1,cos(thet)**(2*t2+1) (table 77-a-2)
    ! *******************************************************************
    function vpip(k)
      implicit real *8(a-h, o-z)
      common /rms/rms(3, 50), s1, s2, s3
      common /gauss1/absg(40), wg(40), igaus
      common /circu/co(40, 50), sn(40, 50), blam(40, 100)
      common /uvtab/epsi1(40, 40), epsi2(40, 40), akpcc(40, 40), akpcs(40, 40), akpsc(40, 40), akpss(40, 40)
      common /expmod/ragp(40, 100), ragm1(40, 40)
      common /uvint/arcc(40, 40), arcs(40, 40), arsc(40, 40), arss(40, 40), cs(40)

      vpip = 0.
      do j = 1, igaus
        u = 0.
        do i = 1, igaus
          u = u + arcs(i, j)*ragm1(i, k)*epsi2(i, j)
        end do
        vpip = vpip + cs(j)*u
      end do
      return
    end function vpip
    ! *******************************************************************
    ! FUNCTION vppi(k)
    ! the integral V(2t3,2t2,2t1+1,k,thet)  table 76
    ! sum wih cos(thet)**2*t1,cos(thet)**(2*t2+1) (table 77-a-2)
    ! *******************************************************************
    function vppi(k)
      implicit real *8(a-h, o-z)
      common /rms/rms(3, 50), s1, s2, s3
      common /gauss1/absg(40), wg(40), igaus
      common /circu/co(40, 50), sn(40, 50), blam(40, 100)
      common /uvtab/epsi1(40, 40), epsi2(40, 40), akpcc(40, 40), akpcs(40, 40), akpsc(40, 40), akpss(40, 40)
      common /expmod/ragp(40, 100), ragm1(40, 40)
      common /uvint/arcc(40, 40), arcs(40, 40), arsc(40, 40), arss(40, 40), cs(40)

      vppi = 0.
      do j = 1, igaus
        u = 0.
        do i = 1, igaus
          u = u + arsc(i, j)*ragm1(i, k)*epsi2(i, j)
        end do
        vppi = vppi + cs(j)*u
      end do
      return
    end function vppi
    ! *******************************************************************
    ! FUNCTION vpii(k)
    ! the integral V(2*t3,2*t2+1,2*t1+1,k,thet)   table 76
    ! sum with cos(thet)**(2*t1+1),cos(thet)**(2*t2+1) (table 77-a-1)
    ! *******************************************************************
    function vpii(k)
      implicit real *8(a-h, o-z)
      common /rms/rms(3, 50), s1, s2, s3
      common /gauss1/absg(40), wg(40), igaus
      common /circu/co(40, 50), sn(40, 50), blam(40, 100)
      common /uvtab/epsi1(40, 40), epsi2(40, 40), akpcc(40, 40), akpcs(40, 40), akpsc(40, 40), akpss(40, 40)
      common /expmod/ragp(40, 100), ragm1(40, 40)
      common /uvint/arcc(40, 40), arcs(40, 40), arsc(40, 40), arss(40, 40), cs(40)

      vpii = 0.
      do j = 1, igaus
        u = 0.
        do i = 1, igaus
          u = u + arss(i, j)*ragm1(i, k)*epsi2(i, j)
        end do
        vpii = vpii + cs(j)*u
      end do
      return
    end function vpii
    ! *******************************************************************
    ! FUNCTION vipp(k)
    ! the integral V(2*t3+1,2*t2,2*t1,thet)  table 76
    ! sum with cos(thet)**2*t1,cos(thet)**2*t2 ( table 77-b-2)
    ! *******************************************************************
    function vipp(k)
      implicit real *8(a-h, o-z)
      common /rms/rms(3, 50), s1, s2, s3
      common /gauss1/absg(40), wg(40), igaus
      common /circu/co(40, 50), sn(40, 50), blam(40, 100)
      common /uvtab/epsi1(40, 40), epsi2(40, 40), akpcc(40, 40), akpcs(40, 40), akpsc(40, 40), akpss(40, 40)
      common /expmod/ragp(40, 100), ragm1(40, 40)
      common /uvint/arcc(40, 40), arcs(40, 40), arsc(40, 40), arss(40, 40), cs(40)

      vipp = 0.
      do j = 1, igaus
        u = 0.
        do i = 1, igaus
          u = u + arcc(i, j)*ragm1(i, k)*epsi2(i, j)
        end do
        vipp = vipp + cs(j)*u
      end do
      return
    end function vipp
    ! *******************************************************************
    ! FUNCTION viip(k)
    ! the integral V(2*t3+1,2*t2+1,2*t1,thet)       table 76
    ! sum with cos(thet)**2*t1,cos(thet)**(2*t2+1) (table 77-b-1)
    ! *******************************************************************
    function viip(k)
      implicit real *8(a-h, o-z)
      common /rms/rms(3, 50), s1, s2, s3
      common /gauss1/absg(40), wg(40), igaus
      common /circu/co(40, 50), sn(40, 50), blam(40, 100)
      common /uvtab/epsi1(40, 40), epsi2(40, 40), akpcc(40, 40), akpcs(40, 40), akpsc(40, 40), akpss(40, 40)
      common /expmod/ragp(40, 100), ragm1(40, 40)
      common /uvint/arcc(40, 40), arcs(40, 40), arsc(40, 40), arss(40, 40), cs(40)

      viip = 0.
      do j = 1, igaus
        u = 0.
        do i = 1, igaus
          u = u + arcs(i, j)*ragm1(i, k)*epsi2(i, j)
        end do
        viip = viip + cs(j)*u
      end do
      return
    end function viip
    ! *******************************************************************
    ! FUNCTION vipi(k)
    ! the integral V(2*t3+1,2*t2,2*t1+1,k,thet)     table 76
    ! sum with cos(thet)**(2*t1+1),cos(thet)**2*t2 (table 77-b-1)
    ! *******************************************************************
    function vipi(k)
      implicit real *8(a-h, o-z)
      common /rms/rms(3, 50), s1, s2, s3
      common /gauss1/absg(40), wg(40), igaus
      common /circu/co(40, 50), sn(40, 50), blam(40, 100)
      common /uvtab/epsi1(40, 40), epsi2(40, 40), akpcc(40, 40), akpcs(40, 40), akpsc(40, 40), akpss(40, 40)
      common /expmod/ragp(40, 100), ragm1(40, 40)
      common /uvint/arcc(40, 40), arcs(40, 40), arsc(40, 40), arss(40, 40), cs(40)

      vipi = 0.
      do j = 1, igaus
        u = 0.
        do i = 1, igaus
          u = u + arsc(i, j)*ragm1(i, k)*epsi2(i, j)
        end do
        vipi = vipi + cs(j)*u
      end do
      return
    end function vipi
    ! *******************************************************************
    ! FUNCTION viii(k)
    ! the integral V(2*t3+1,2*t2+1,2*t1+1,thet)      in table 76
    ! sum with cos(thet)**(2*t1+1),cos(thet)**(2*t2+1) (table 77-b-2)
    ! *******************************************************************
    function viii(k)
      implicit real *8(a-h, o-z)
      common /rms/rms(3, 50), s1, s2, s3
      common /gauss1/absg(40), wg(40), igaus
      common /circu/co(40, 50), sn(40, 50), blam(40, 100)
      common /uvtab/epsi1(40, 40), epsi2(40, 40), akpcc(40, 40), akpcs(40, 40), akpsc(40, 40), akpss(40, 40)
      common /expmod/ragp(40, 100), ragm1(40, 40)
      common /uvint/arcc(40, 40), arcs(40, 40), arsc(40, 40), arss(40, 40), cs(40)

      viii = 0.
      do j = 1, igaus
        u = 0.
        do i = 1, igaus
          u = u + arss(i, j)*ragm1(i, k)*epsi2(i, j)
        end do
        viii = viii + cs(j)*u
      end do
      return
    end function viii
    ! *******************************************************************
    ! SUBROUTINE pintfast
    ! Particles too far from the C. of G. of the bunch are eliminated
    ! for the Almn computations with HERSC
    ! *******************************************************************
    subroutine pintfast
      implicit real *8(a-h, o-z)
      parameter(iptsz=100002, maxcell=3000, maxcell1=3000)
      common /faisc/f(10, iptsz), imax, ngood
      common /consta/vl, pi, xmat, rpel, qst
      common /dyn/tref, vref
      common /sc3/beamc, scdist, sce10, cplm, ectt, apl, ichaes, iscsp
      common /ttfc/tk, t1k, t2k, sk, s1k, s2k, fh
      common /part/xc(iptsz), yc(iptsz), zc(iptsz)
      common /dimens/zcp(iptsz), xcp(iptsz), ycp(iptsz)
      common /nume/nuelm
      common /vpintim/gcg, bcg
      common /coef/a(30, 30, 30), xrmsz, yrmsz, zrmsz
      common /macro/ratei

      nuelm = nuelm + 1
      write (16, *) ' space charge with HERSC call number: ', nuelm
      trmoy = 0.
      wcg = 0.
      xcg = 0.
      xcg = 0.
      ycg = 0.
      do i = 1, ngood
        trmoy = trmoy + f(6, i)
        wcg = wcg + f(7, i)
        xcg = xcg + f(2, i)
        ycg = ycg + f(4, i)
      end do
      trmoy = trmoy/float(ngood)
      wcg = wcg/float(ngood)
      gcg = wcg/xmat
      bcg = sqrt(1.-1./(gcg*gcg))
      xcg = xcg/float(ngood)
      ycg = ycg/float(ngood)
      zcg = trmoy*fh
      ! Isochronism correction in bending magnet
      ! apl is the angle due to the lack of isochronicity in the plane (x,z)
      ! (see : A modified space charge routine for high intensity bunched
      ! beam,P.Lapostolle and 5 authors,NIM A Vol.379,pp21-40,
      ! September 1996)
      ! does not work with SCHEFF method (iscsp=3)
      apl = 0.
      if (iscsp<=2) then
        xb2x = 0.
        xb2z = 0.
        xbxz = 0.
        imaxx = 0
        do np = 1, ngood
          gnp = f(7, np)/xmat
          bnp = sqrt(1.-1./(gnp*gnp))
          zc(np) = (trmoy-f(6,np))*bnp*vl/100.
          ! *   correct. relativiste
          ! omment           zc(np)=zc(np)*gcg
          ! *
          xc(np) = (f(2,np)-xcg)/100.
          xb2z = xb2z + zc(np)*zc(np)
          xb2x = xb2x + xc(np)*xc(np)
          xbxz = xbxz + zc(np)*xc(np)
          imaxx = imaxx + 1
        end do
        xb2z = xb2z/float(imaxx)
        xb2x = xb2x/float(imaxx)
        xbxz = xbxz/float(imaxx)
        apl = atan(-2.*xbxz/(xb2x-xb2z))/2.
      end if
      write (16, *) '*slope of the bunch in plane(Oz,Ox):', apl, ' radian'
      ! bunch at the space charge position
      xbar = 0.
      ybar = 0.
      zbar = 0.
      imaxx = 0
      ! Divide by 100. to convert from centimeters to meters
      do np = 1, ngood
        gnp = f(7, np)/xmat
        bnp = sqrt(1.-1./(gnp*gnp))
        znp = (trmoy-f(6,np))*bnp*vl
        ! *   correct. relativiste valero
        ! omment         znp=znp*gcg
        ! *
        xnp = f(2, np)
        zc(np) = znp*cos(apl) + xnp*sin(apl)
        xnp = xnp*cos(apl) - znp*sin(apl)
        ! convert from mrad to rad
        f3 = f(3, np)*1.e-03
        f5 = f(5, np)*1.e-03
        ! convert from cm   to m
        xc(np) = (xnp+zc(np)*f3)/100.
        yc(np) = (f(4,np)+zc(np)*f5)/100.
        zc(np) = zc(np)/100.
        ! evaluate xbar , ybar , zbar
        xbar = xbar + xc(np)
        ybar = ybar + yc(np)
        zbar = zbar + zc(np)
      end do
      eng = float(ngood)
      xbar = xbar/eng
      ybar = ybar/eng
      zbar = zbar/eng
      do np = 1, ngood
        xc(np) = xc(np) - xbar
        yc(np) = yc(np) - ybar
        zc(np) = zc(np) - zbar
      end do
      return
    end subroutine pintfast
    ! *******************************************************************
    ! SUBROUTINE hcoef
    ! the significant Hermite coefficients (called by HERSC)
    ! *******************************************************************
    subroutine hcoef
      implicit real *8(a-h, o-z)
      parameter(iptsz=100002, maxcell=3000, maxcell1=3000)
      common /faisc/f(10, iptsz), imax, ngood
      common /consta/vl, pi, xmat, rpel, qst
      common /const/pi2, sqpi, pwtpi, sqpi2, sq2pi
      common /hcgrms/xcdg, ycdg, zcdg, ect, eps
      common /ind/lmax, mmax, nmax
      common /indttal/lmnt
      common /randu/ck(15), kmax
      common /coef/a(30, 30, 30), xrmsz, yrmsz, zrmsz
      common /part/xc(iptsz), yc(iptsz), zc(iptsz)
      common /isoch/apl
      common /dimens/zcp(iptsz), xcp(iptsz), ycp(iptsz)
      common /nume/nuelm
      common /macro/ratei
      common /facrms/fxrms, fyrms, fzrms
      common /rcoef/rdcf
      common /factor/fpir(40, 40), fect(30)
      dimension hx(30), hy(30), hz(30), tran(1)
      ! calculation of Hermite coefficients on the principal axis in x,y,z
      do i = 1, ngood
        zcp(i) = zc(i)
        xcp(i) = xc(i)
        ycp(i) = yc(i)
      end do
      do kn = 1, nmax
        do km = 1, mmax
          do kl = 1, lmax
            a(kl, km, kn) = 0.
          end do
        end do
      end do
      zcg = 0.
      xcg = 0.
      ycg = 0.
      do i = 1, ngood
        zcg = zcg + zc(i)
        xcg = xcg + xc(i)
        ycg = ycg + yc(i)
      end do
      xcg = xcg/float(ngood)
      ycg = ycg/float(ngood)
      zcg = zcg/float(ngood)
      xsqsum = 0.
      ysqsum = 0.
      zsqsum = 0.
      ! evaluate the rms sizes
      do j = 1, ngood
        xcj = xc(j) - xcg
        ycj = yc(j) - ycg
        zcj = zc(j) - zcg
        xsqsum = xsqsum + xcj*xcj
        ysqsum = ysqsum + ycj*ycj
        zsqsum = zsqsum + zcj*zcj
      end do
      xrmsz = xsqsum/float(ngood)
      yrmsz = ysqsum/float(ngood)
      zrmsz = zsqsum/float(ngood)
      xrmsz = sqrt(xrmsz)
      yrmsz = sqrt(yrmsz)
      zrmsz = sqrt(zrmsz)
      write (16, *) '*RMS of the bunch (m): ', xrmsz, yrmsz, zrmsz
      ! omment       write(17,25) nuelm,xrmsz,yrmsz,zrmsz
      ! omment25     format(2x,i5,3(2x,e12.5))
      ! ***TEST control s.c.
      ! omment        rewind(19)
      ! omment        irep=0
      ! omment        rewind(21)
      ! omment        write(21,*) '      x(cm)         y(cm)         z(cm)'
      ! coordinates of the bunch  x, y, z
      ! omment        do j=1,ngood
      ! omment          xcoup=(xcp(j)-xcg)/xrmsz
      ! omment          ycoup=(ycp(j)-ycg)/yrmsz
      ! omment          zcoup=(zcp(j)-zcg)/zrmsz
      ! omment          write(21,1188) xcoup,ycoup,zcoup
      ! omment          if((abs(xcoup).lt.fxrms).and.(abs(ycoup).lt.fyrms).and.
      ! omment     *      (abs(zcoup).lt.fzrms)) then
      ! omment           write(19,1188) xcoup,ycoup,zcoup
      ! omment           irep=irep+1
      ! omment          endif
      ! omment        enddo
      ! omment1188     format(3(2x,e12.5))
      ! ***END TEST control s.c.
      if (rdcf>=1.) then
        hz(1) = 1.
        hy(1) = 1.
        hx(1) = 1.
        irct = 0
        do j = 1, ngood
          xc(j) = (xcp(j)-xcg)/xrmsz
          yc(j) = (ycp(j)-ycg)/yrmsz
          zc(j) = (zcp(j)-zcg)/zrmsz
          if ((abs(xc(j))<fxrms) .and. (abs(yc(j))<fyrms) .and. (abs(zc(j))<fzrms)) then
            irct = irct + 1
            ach = abs(f(9,j))
            hz(2) = zc(j)
            hy(2) = yc(j)
            hx(2) = xc(j)
            do kn = 1, nmax
              if (kn>2) hz(kn) = zc(j)*hz(kn-1) - float(kn-2)*hz(kn-2)
              do km = 1, mmax
                if (km>2) hy(km) = yc(j)*hy(km-1) - float(km-2)*hy(km-2)
                do kl = 1, lmax
                  if (kl>2) hx(kl) = xc(j)*hx(kl-1) - float(kl-2)*hx(kl-2)
                  xherm = hx(kl)*hy(km)*hz(kn)/(fect(kl)*fect(km)*fect(kn))
                  a(kl, km, kn) = a(kl, km, kn) + xherm/pwtpi*ach
                end do
              end do
            end do
          end if
        end do
        rate = float(ngood)/float(irct)
        ! write(16,*) ' particles kept in Almn computation: ',irct
        do kn = 1, nmax
          do km = 1, mmax
            do kl = 1, lmax
              a(kl, km, kn) = a(kl, km, kn)*rate
            end do
          end do
        end do
      end if
      ! *********************************
      if (rdcf<1.) then
        rdcfc = rdcf*float(imax)/float(ngood)
        if (rdcfc>1.) rdcfc = 1.
        len = 1
        irct = 0
        hz(1) = 1.
        hy(1) = 1.
        hx(1) = 1.
        do j = 1, ngood
          call rlux(tran, len)
          if (tran(1)<=rdcfc) then
            xc(j) = (xcp(j)-xcg)/xrmsz
            yc(j) = (ycp(j)-ycg)/yrmsz
            zc(j) = (zcp(j)-zcg)/zrmsz
            if ((abs(xc(j))<fxrms) .and. (abs(yc(j))<=fyrms) .and. (abs(zc(j))<fzrms)) then
              ach = abs(f(9,j))
              irct = irct + 1
              hz(2) = zc(j)
              hy(2) = yc(j)
              hx(2) = xc(j)
              do kn = 1, nmax
                if (kn>2) hz(kn) = zc(j)*hz(kn-1) - float(kn-2)*hz(kn-2)
                do km = 1, mmax
                  if (km>2) hy(km) = yc(j)*hy(km-1) - float(km-2)*hy(km-2)
                  do kl = 1, lmax
                    if (kl>2) hx(kl) = xc(j)*hx(kl-1) - float(kl-2)*hx(kl-2)
                    xherm = hx(kl)*hy(km)*hz(kn)/(fect(kl)*fect(km)*fect(kn))
                    a(kl, km, kn) = a(kl, km, kn) + xherm/pwtpi*ach
                  end do
                end do
              end do
            end if
          end if
        end do
        rate = float(ngood)/float(irct)
        write (16, *) ' particles kept in Almn: ', irct
        do kn = 1, nmax
          do km = 1, mmax
            do kl = 1, lmax
              a(kl, km, kn) = a(kl, km, kn)*rate
            end do
          end do
        end do
      end if
      ! 118    format(3(2x,e12.5))
      ! *  cesaro  transformation
      lsup = lmax
      msup = mmax
      nsup = nmax
      do kn = 1, nsup
        do km = 1, msup
          do kl = 1, lsup
            cesl = (1.-float(kl-1)/float(lsup))
            cesm = (1.-float(km-1)/float(msup))
            cesn = (1.-float(kn-1)/float(nsup))
            ces = cesl*cesm*cesn
            ! esaro force             a(kl,km,kn)=a(kl,km,kn)*ces*ces
            a(kl, km, kn) = a(kl, km, kn)*ces
          end do
        end do
      end do
      ! *
      ! select the significant coefficients
      ! 999    continue
      fond = abs(a(1,1,1))
      itot = 0
      iret = 0
      do kn = 1, nmax
        n = kn - 1
        ipar = n - 2*int(n/2)
        if (ipar==0) zz = 0.
        if (ipar/=0) then
          if (n==1) zz = 1.
          if (n==3) zz = .75
          if (n==5) zz = .625
          if (n>5 .and. n<=11) zz = 0.50
          if (n>11) zz = 0.375
        end if
        do km = 1, mmax
          m = km - 1
          ipar = m - 2*int(m/2)
          if (ipar==0) yy = 0.
          if (ipar/=0) then
            if (m==1) yy = 1.
            if (m==3) yy = .75
            if (m==5) yy = .625
            if (m>5 .and. m<=11) yy = 0.50
            if (m>11) yy = 0.375
          end if
          do kl = 1, lmax
            l = kl - 1
            ipar = l - 2*int(l/2)
            if (ipar==0) xx = 0.
            if (ipar/=0) then
              if (l==1) xx = 1.
              if (l==3) xx = .75
              if (l==5) xx = .625
              if (l>5 .and. l<=11) xx = 0.50
              if (l>11) xx = 0.375
            end if
            itot = itot + 1
            xherm = hermint(xx, l)*hermint(yy, m)*hermint(zz, n)
            ab = abs(a(kl,km,kn)*xherm)/fond
            if (ab>=eps) then
              iret = iret + 1
            else
              a(kl, km, kn) = 0.
            end if
          end do
        end do
      end do
      rpeps = float(iret)/float(itot)
      write (16, *) '*significant terms in Hermite series expansion: ', iret, ' total of terms :', itot
      if (rpeps>=.3) then
        write (16, *) ' problem in space charge : rpeps gt .3 ', rpeps
        stop
      end if
      ! select the maximum values l, m and n for the significant coefficients
      lsup = 0
      msup = 0
      nsup = 0
      lmnt = 0
      do kn = 1, nmax
        do km = 1, mmax
          do kl = 1, lmax
            if (a(kl,km,kn)/=0.) then
              itm = kl + km + kn - 3
              if (itm>=lmnt) lmnt = itm
              if (lsup<=kl) lsup = kl
              if (msup<=km) msup = km
              if (nsup<=kn) nsup = kn
            end if
          end do
        end do
      end do
      lmnt = lmnt + kmax + 4 + 3
      write (16, *) ' maximum of n m l for the significants terms ', nsup - 1, msup - 1, lsup - 1
      write (16, *) ' maximun of (t) for the significants terms ', lmnt
      ! *  cesaro  transformation
      ! cc         do kn=1,nsup
      ! cc           do km=1,msup
      ! cc             do kl=1,lsup
      ! cc               cesl=(1.-float(kl-1)/float(lsup))
      ! cc               cesm=(1.-float(km-1)/float(msup))
      ! cc               cesn=(1.-float(kn-1)/float(nsup))
      ! cc               ces=cesl*cesm*cesn
      ! cc              a(kl,km,kn)=a(kl,km,kn)*ces
      ! cc             enddo
      ! cc           enddo
      ! cc         enddo
      ! *
      return
    end subroutine hcoef
    ! *******************************************************************
    ! SUBROUTINE hersc(ini)
    ! space charge method: HERSC
    ! *******************************************************************
    subroutine hersc(ini)
      implicit real *8(a-h, o-z)
      parameter(iptsz=100002, maxcell=3000, maxcell1=3000)
      common /faisc/f(10, iptsz), imax, ngood
      common /consta/vl, pi, xmat, rpel, qst
      common /sc3/beamc, scdist, sce10, cplm, ectt, apl, ichaes, iscsp
      common /ttfc/tk, t1k, t2k, sk, s1k, s2k, fh
      common /cdek/dwp(iptsz)
      common /part/xc(iptsz), yc(iptsz), zc(iptsz)
      common /coef/a(30, 30, 30), xrmsz, yrmsz, zrmsz
      common /hcgrms/xcdg, ycdg, zcdg, ect, eps
      common /ind/lmax, mmax, nmax
      common /indin/lmaxi, mmaxi, nmaxxi
      common /indttal/lmnt
      common /rms/rms(3, 50), s1, s2, s3
      common /randu/ck(15), kmax
      common /circu/co(40, 50), sn(40, 50), blam(40, 100)
      common /gauss1/absg(40), wg(40), igaus
      common /field/ex, ey, ez
      common /expmod/ragp(40, 100), ragm1(40, 40)
      common /const/pi2, sqpi, pwtpi, sqpi2, sq2pi
      common /facrms/fxrms, fyrms, fzrms
      common /dimens/zcp(iptsz), xcp(iptsz), ycp(iptsz)
      common /beamsa/fs(7, iptsz)
      common /dcspa/iesp
      common /cmpte/iell
      common /npart/imaxr
      common /compt/nrres, nrtre, nrbunc, nrdbun
      common /rcoef/rdcf
      common /macro/ratei
      common /tapes/in, ifile, meta
      common /posc/xpsc
      common /locher/rx, ry, rz, nx, ny, nz
      logical ichaes, iesp
      dimension exk(15, 15, 30), eyk(15, 15, 30), ezk(15, 15, 30)
      data lbmax, mbmax, nbmax/23, 23, 23/
      ! ini = 0 :initialisation of the routine
      if (ini<=0) then
        sq2pi = sqrt(2.*pi)
        ! input parameters
        igaus = 9
        ! eps allows to select the significant terms in the HERMITE series expansion
        eps = 8.e-03
        ! maximun of the upper limits in the HERMITE series expansion
        lmaxi = 11
        mmaxi = 11
        nmaxxi = 11
        ! The HERMITE coefficients Almn are computed with the particles include in a cube
        ! with regard to the RMS of the bunch. The sizes of the cube are:RMSx*fxrms, ........
        fxrms = 2.5
        fyrms = 2.5
        fzrms = 2.5
        if (ini<0) then
          read (in, *) lmaxi, mmaxi, nmaxxi
          write (16, *) 'upper limits ', lmaxi, mmaxi, nmaxxi
          read (in, *) fxrms, fyrms, fzrms
          write (16, *) ' rms factors', fxrms, fyrms, fzrms
          read (in, *) eps
          write (16, *) ' select the Hermite cefficients with: ', eps
        end if
        ! MESH**********
        ! limits in (+-) RMS
        rx = 4.
        ry = 4.
        rz = 4.
        ! number of nodes in each direction
        nx = 8
        ny = 8
        nz = 8
        ! rdcf   : in %/100 , allows to select a reduced number of particles for the Almn.
        call shuffle
        call gausse
        read (in, *) rdcf
        if (rdcf>1.) rdcf = 1.
        if (rdcf<=0.) then
          if (ngood>15000) then
            rdcf = 15000./float(ngood)
          else
            rdcf = 1.
          end if
        end if
        call table(lbmax, mbmax, nbmax)
        return
      end if
      ! **********************************************************************
      if (ini==1) then
        ! .................................................................................
        ! seeks: the significant coefficients  in the Hermite series expansions
        ! ---> storage array a(l,m,n)
        ! maximum values of l,m and n of the significants a(l,m,n) --->lmax,mmax,nmax
        ! RMS of the bunch ---> xa,xb and xc
        ! order of the succesives integrals
        ! isucc=1: xa<xb,xc , rms(3,2)=xa, rms(2,2)=xb,  rms(1,2)=xc
        ! rms(3,k)=xa**(k-1), ..........
        ! isucc=2: xb<xa,xc , rms(3,2)=xb, rms(2,2)=xc,  rms(1,2)=xa
        ! isucc=1: xc<xa,xb , rms(3,2)=xc, rms(2,2)=xa,  rms(1,2)=xb
        ! compute the array blam(i,j)
        ! blam(i,j): FUNCTION beta**2 in the fifth relation in table 31
        ! blam(i,j)=beta**2j,j=1,...,im=(lmax+mmax+nmax+kmax)/2+2
        ! i is given from the i-Gauss position in absg(i)
        ! ..................................................................................
        call bhdist
        call trms(isucc)
        sta = a(1, 1, 1)
        icoa = 0
        do ican = 1, nmax
          do icam = 1, mmax
            do ical = 1, lmax
              if (a(ican,icam,ical)/=0.) icoa = icoa + 1
            end do
          end do
        end do
        return
      end if
      ! **********************************************************************
      ! beam self-fields
      if (ini==2) then
        ! limits of the mesch : rx ry rz
        ! length of the steps
        delx = 2.*rx/float(nx)
        dely = 2.*ry/float(ny)
        delz = 2.*rz/float(nz)
        ! Initialize constants
        ! xmass-Kg,wavel=cm,charge=coul.
        ! clight=cm/sec MHz/Hz ,freq=Mhz ,xmat=MeV
        ! freq. in MHz
        freq = fh*0.5e-06/pi
        epsilon = 8.854189586e-12
        const3 = 1.e-06
        const2 = 1.e-06/xmat
        dxp = 0.
        dyp = 0.
        dw = 0.
        dz = scdist/100.
        dz1 = dz
        zsot1 = 0.
        ! qmpart=macro-charge
        qmpart = 1.0e-9*beamc/(float(imax)*freq)
        if (ratei<=0.) then
          write (16, *) ' all the particles are lost '
          stop
        end if
        qmpart = qmpart*ratei
        vrms = xrmsz*yrmsz*zrmsz
        cmacro = qmpart/(epsilon*vrms)
        wcg = 0.
        do i = 1, ngood
          wcg = wcg + f(7, i)
        end do
        wcg = wcg/float(ngood)
        gcg = wcg/xmat
        gmoy = gcg
        bcg = sqrt(1.-1./(gcg*gcg))
        bmoy = bcg
        ! relativistic correction
        cmacro = cmacro/gmoy

        cmacrxy = cmacro/(bmoy*bmoy*gmoy*gmoy)
        ! beam self-fields at the nodes of the mesh
        imail = 0
        rcy = -ry
        do j = 1, ny
          rcx = -rx
          do i = 1, nx
            rcz = -rz
            do k = 1, nz
              if (isucc==1) then
                s3 = rcx
                s2 = rcy
                s1 = rcz
                ax = pwtpi*rms(3, 2)
                ay = pwtpi*rms(2, 2)
                az = pwtpi*rms(1, 2)
                rrx = rms(3, 2)
                rry = rms(2, 2)
                rrz = rms(1, 2)
              end if
              if (isucc==2) then
                s3 = rcy
                s2 = rcz
                s1 = rcx
                ax = pwtpi*rms(1, 2)
                ay = pwtpi*rms(3, 2)
                az = pwtpi*rms(2, 2)
                rrx = rms(1, 2)
                rry = rms(3, 2)
                rrz = rms(2, 2)
              end if
              if (isucc==3) then
                s3 = rcz
                s2 = rcx
                s1 = rcy
                ax = pwtpi*rms(2, 2)
                ay = pwtpi*rms(1, 2)
                az = pwtpi*rms(3, 2)
                rrx = rms(2, 2)
                rry = rms(1, 2)
                rrz = rms(3, 2)
              end if
              call uvrms
              ! fields
              ! loop over the l,m and n
              exk(i, j, k) = 0.
              eyk(i, j, k) = 0.
              ezk(i, j, k) = 0.
              do jn = 1, nmax
                jn1 = jn - 1
                do jm = 1, mmax
                  jm1 = jm - 1
                  do jl = 1, lmax
                    jl1 = jl - 1
                    if (a(jl,jm,jn)/=0.) then
                      call fielde(jl1, jm1, jn1, isucc)
                      ! the beam self-fields are  in tables 67-a to 67-h
                      exk(i, j, k) = a(jl, jm, jn)/ax*ex + exk(i, j, k)
                      eyk(i, j, k) = a(jl, jm, jn)/ay*ey + eyk(i, j, k)
                      ezk(i, j, k) = a(jl, jm, jn)/az*ez + ezk(i, j, k)
                    end if
                  end do
                end do
              end do
              rcz = rcz + delz
              imail = imail + 1
            end do
            rcx = rcx + delx
          end do
          rcy = rcy + dely
        end do
        ! xi in Amps, ibeam in mA
        dxp = 0.
        dyp = 0.
        dw = 0.
        ! save the  particles coordinates
        do i = 1, ngood
          xc(i) = xcp(i)
          yc(i) = ycp(i)
          zc(i) = zcp(i)
        end do
        ! Do integration to determine Ex,Ey,Ez for each macro particle
        nprint = 1
        insd = 0
        iout = 0
        ickl = 0
        do ic = 1, ngood
          ! position in the mesh
          ickl = ickl + 1
          ! *    valero
          u = xc(ic)/xrmsz
          v = yc(ic)/yrmsz
          w = zc(ic)/zrmsz
          ! omment           u=xc(ic)/rrx
          ! omment           v=yc(ic)/rry
          ! omment           w=zc(ic)/rrz
          i = int((u+rx)/delx) + 1
          j = int((v+ry)/dely) + 1
          k = int((w+rz)/delz) + 1
          ! the particle is in the mesh
          if (i>0 .and. i<=nx .and. j>0 .and. j<=ny .and. k>0 .and. k<=nz) then
            xnd1 = -rx + float(i-1)*delx
            ynd1 = -ry + float(j-1)*dely
            znd1 = -rz + float(k-1)*delz
            delu = u - xnd1
            delv = v - ynd1
            delw = w - znd1
            delux = delu/delx
            delvy = delv/dely
            delwz = delw/delz
            ! *******interpollation for particle inside a cube
            ! %%%%%%     in plane 1:
            ! node 1: (i,j,k)  node 2:(i+1,j,k) node 3:(i+1,j,k+1) node 4:(i,j,k+1)
            ! axis (nd1,nd2)
            ex12 = (exk(i+1,j,k)-exk(i,j,k))*delux + exk(i, j, k)
            ! axis (nd4,nd3)
            ex43 = (exk(i+1,j,k+1)-exk(i,j,k+1))*delux + exk(i, j, k+1)
            ! plane 1
            exp1 = (ex43-ex12)*delwz + ex12
            ! %%%%%%%     in plane 3:
            ! node 5:(i,j+1,k) node 6:(i+1,j+1,k) node 7:(i+1,j+1,k+1) node 8:(i,j+1,k+1)
            ! axis(nd5,nd6)
            ex56 = (exk(i+1,j+1,k)-exk(i,j+1,k))*delux + exk(i, j+1, k)
            ! axis(nd8,nd7)
            ex87 = (exk(i+1,j+1,k+1)-exk(i,j+1,k+1))*delux + exk(i, j+1, k+1)
            ! plane 3
            exp3 = (ex87-ex56)*delwz + ex56
            ! $$$$$ plane1+plane3
            exp13 = (exp3-exp1)*delvy + exp1
            ! %%%%%    in plane 2:
            ! node 1: (i,j,k)  node 2:(i+1,j,k) node 5:(i,j+1,k) node 6:(i+1,j+1,k)
            ! axis (nd1,nd2) : ex12
            ! axis (nd5,nd6) : ex56
            ! plane 2
            exp2 = (ex56-ex12)*delvy + ex12
            ! %%%%%%    in plane 5
            ! node 4:(i,j,k+1) node 3:(i+1,j,k+1) node 8:(i,j+1,k+1) node 7:(i+1,j+1,k+1)
            ! axis(nd4,nd3)
            ex43 = (exk(i+1,j,k+1)-exk(i,j,k+1))*delux + exk(i, j, k+1)
            ! axis(nd8,nd7)
            ex87 = (exk(i+1,j+1,k+1)-exk(i,j+1,k+1))*delux + exk(i, j+1, k+1)
            ! plane 5
            exp5 = (ex87-ex43)*delvy + ex43
            ! $$$$ plane2+plane5
            exp25 = (exp5-exp2)*delwz + exp2
            ! &&&& (plane1+plane3)+(plane2+plane5) --> field Ex(u,v,w)
            ext = (exp13+exp25)/2.
            ! ******* field component Ey
            ! %%%%%%     in plane 2:
            ! node 1: (i,j,k)  node 2:(i+1,j,k) node 5:(i,j+1,k) node 6:(i+1,j+1,k)
            ! axis(nd1,nd5)
            ey15 = (eyk(i,j+1,k)-eyk(i,j,k))*delvy + eyk(i, j, k)
            ! axis (nd2,nd6)
            ey26 = (eyk(i+1,j+1,k)-eyk(i+1,j,k))*delvy + eyk(i+1, j, k)
            ! plane 2
            eyp2 = (ey26-ey15)*delu/delx + ey15
            ! %%%%%%     in plane 5:
            ! node 4:(i,j,k+1) node 3:(i+1,j,k+1) node 8:(i,j+1,k+1) node 7:(i+1,j+1,k+1)
            ! axis(nd4,nd8)
            ey48 = (eyk(i,j+1,k+1)-eyk(i,j,k+1))*delvy + eyk(i, j, k+1)
            ! axis(nd3,nd7)
            ey37 = (eyk(i+1,j+1,k+1)-eyk(i+1,j,k+1))*delvy + eyk(i+1, j, k+1)
            ! plane 5
            eyp5 = (ey37-ey48)*delux + ey48
            ! $$$$$$ plane2+plane5
            eyp25 = (eyp5-eyp2)*delwz + eyp2
            ! %%%%%%     in plane 6:
            ! node 1:(i,j,k) node 5:(i,j+1,k) node 4:(i,j,k+1) node 8:(i,j+1,k+1)
            ! axis(nd1,nd5): ey15
            ! axis(nd4,nd8): ey48
            ! plane 6
            eyp6 = (ey48-ey15)*delwz + ey15
            ! %%%%%%     in plane 4:
            ! node 2:(i+1,j,k) node 3:(i+1,j,k+1) node 6:(i+1,j+1,k) node 7:(i+1,j+1,k+1)
            ! axis(nd2,nd6): ey26
            ! axis(nd3,nd7): ey37
            ! plane 4
            eyp4 = (ey37-ey26)*delwz + ey26
            ! $$$$plane6+plane4
            eyp46 = (eyp4-eyp6)*delux + eyp6
            ! £££ (plane2+plane5)+(plane4+plane6)--> field Ez(u,v,w)
            eyt = (eyp25+eyp46)/2.
            ! *******interpollation of the field component Ez
            ! %%%%%%     in plane 1:
            ! node 1:(i,j,k) node 2:(i+1,j,k) node 3:(i+1,j,k+1) node 4:(i,j,k+1)
            ! axis(nd1,nd4)
            ez14 = (ezk(i,j,k+1)-ezk(i,j,k))*delwz + ezk(i, j, k)
            ! axis(nd2,nd3)
            ez23 = (ezk(i+1,j,k+1)-ezk(i+1,j,k))*delwz + ezk(i+1, j, k)
            ! plane 1
            ezp1 = (ez23-ez14)*delux + ez14
            ! %%%%%%     in plane 3:
            ! node 5:(i,j+1,k) node 6:(i+1,j+1,k) node 7:(i+1,j+1,k+1) node 8:(i,j+1,k+1)
            ! axis (nd5,nd8)
            ez58 = (ezk(i,j+1,k+1)-ezk(i,j+1,k))*delwz + ezk(i, j+1, k)
            ! axis (nd6,nd7)
            ez67 = (ezk(i+1,j+1,k+1)-ezk(i+1,j+1,k))*delwz + ezk(i+1, j+1, k)
            ! plane 3
            ezp3 = (ez67-ez58)*delux + ez58
            ! $$$$$$ plane1+plane3
            ezp13 = (ezp3-ezp1)*delvy + ezp1
            ! %%%%%%     in plane 6:
            ! node 1:(i,j,k) node 5:(i,j+1,k) node 4:(i,j,k+1) node 8:(i,j+1,k+1)
            ! axis (nd1,nd4)
            ez14 = (ezk(i,j,k+1)-ezk(i,j,k))*delwz + ezk(i, j, k)
            ! axis (nd5,nd8)
            ez58 = (ezk(i,j+1,k+1)-ezk(i,j+1,k))*delwz + ezk(i, j+1, k)
            ! plane 6
            ezp6 = (ez58-ez14)*delvy + ez14
            ! %%%%%%     in plane 4:
            ! node 2:(i+1,j,k) node 3:(i+1,j,k+1) node 6:(i+1,j+1,k) node 7:(i+1,j+1,k+1)
            ! axis(nd2,nd3)
            ez23 = (ezk(i+1,j,k+1)-ezk(i+1,j,k))*delwz + ezk(i+1, j, k)
            ! axis(nd6,nd7)
            ez67 = (ezk(i+1,j+1,k+1)-ezk(i+1,j+1,k))*delwz + ezk(i+1, j+1, k)
            ! plane 4
            ezp4 = (ez67-ez23)*delvy + ez23
            ! $$$$$$ plane6+plane4
            ezp64 = (ezp4-ezp6)*delux + ezp6
            ! £££££££ (P1+P3)+(P6+P4)----> Ez(u,v,w)
            ezt = (ezp13+ezp64)/2.
            insd = insd + 1
            ! calculate kicks in x',y' and z' (energy)
            eztp = ezt*cos(apl) - ext*sin(apl)
            extp = ezt*sin(apl) + ext*cos(apl)
            ezt = eztp
            ext = extp
            gsc = f(7, ic)/xmat
            bsc = sqrt(1.-1./(gsc*gsc))
            ! omment             cmacrxy=cmacro/(bmoy*bmoy*gmoy*gmoy*gmoy)
            ! omment             cmacrxy=cmacro/(bsc*bsc*gsc*gsc)
            dxp = const2*ext*dz*cmacrxy*abs(f(9,ic))
            dyp = const2*eyt*dz*cmacrxy*abs(f(9,ic))
            dw = const3*ezt*dz*cmacro*abs(f(9,ic))
            ! ****test************************************
            ! omment              dw=dw/gmoy
            ! ****************************************
            if (.not. iesp) then
              ! load the entrance beam parameters for cavities or gaps
              do js = 1, 7
                f(js, ic) = fs(js, ic)
              end do
              f(3, ic) = f(3, ic) + dxp*1000.
              f(5, ic) = f(5, ic) + dyp*1000.
              f(2, ic) = f(2, ic) - dz1*dxp*100.*xpsc
              f(4, ic) = f(4, ic) - dz1*dyp*100.*xpsc
              ! omment               f(2,ic)=f(2,ic)-dz1*dxp*100.
              ! omment               f(4,ic)=f(4,ic)-dz1*dyp*100.
              dwp(ic) = dw
            else
              f(3, ic) = f(3, ic) + dxp*1000.
              f(5, ic) = f(5, ic) + dyp*1000.
              f(7, ic) = f(7, ic) + dw
            end if
          else
            ! the particle is not in the mesh
            ! computed the beam self-fields as made at the nodes
            ax = 0.
            ay = 0.
            az = 0.
            if (isucc==1) then
              s3 = xc(ic)/rms(3, 2)
              s2 = yc(ic)/rms(2, 2)
              s1 = zc(ic)/rms(1, 2)
              ax = pwtpi*rms(3, 2)
              ay = pwtpi*rms(2, 2)
              az = pwtpi*rms(1, 2)
              rrx = rms(3, 2)
              rry = rms(2, 2)
              rrz = rms(1, 2)
            end if
            if (isucc==2) then
              s3 = yc(ic)/rms(3, 2)
              s2 = zc(ic)/rms(2, 2)
              s1 = xc(ic)/rms(1, 2)
              ax = pwtpi*rms(1, 2)
              ay = pwtpi*rms(3, 2)
              az = pwtpi*rms(2, 2)
              rrx = rms(1, 2)
              rry = rms(3, 2)
              rrz = rms(2, 2)
            end if
            if (isucc==3) then
              s3 = zc(ic)/rms(3, 2)
              s2 = xc(ic)/rms(2, 2)
              s1 = yc(ic)/rms(1, 2)
              ax = pwtpi*rms(2, 2)
              ay = pwtpi*rms(1, 2)
              az = pwtpi*rms(3, 2)
              rrx = rms(2, 2)
              rry = rms(1, 2)
              rrz = rms(3, 2)
            end if
            ! storage arrays of the functions in the integrals in tables 75 and 76
            ! these values given in table 73 are independent of l, m and n
            ! They are stored in: epsi1(i,j),epsi2(i,j), akpc1(i,j), akpc2(i,j),
            ! akps1(i,j), akps2(i,j) where i,j are the Gauss positions
            call uvrms
            ! field computation
            ! loop over the l,m and n
            ext = 0.
            eyt = 0.
            ezt = 0.
            do jn = 1, nmax
              jn1 = jn - 1
              do jm = 1, mmax
                jm1 = jm - 1
                do jl = 1, lmax
                  jl1 = jl - 1
                  if (a(jl,jm,jn)/=0.) then
                    ! in output the SUBROUTINE field returns the values of the FUNCTION E*(l,m,n)
                    ! shown in tables 77-a-1 to 77-b-2 in x,y and z-directions-->ex,ey,ez
                    call fielde(jl1, jm1, jn1, isucc)
                    ! the corresonding field components are obtained from tables 67-a to 67-h
                    ext = a(jl, jm, jn)/ax*ex + ext
                    eyt = a(jl, jm, jn)/ay*ey + eyt
                    ezt = a(jl, jm, jn)/az*ez + ezt
                  end if
                end do
              end do
            end do
            iout = iout + 1
            ! kicks
            ! kicks computation
            ! calculate kick in x',y' and z' (energy)
            ! isochronism correction
            eztp = ezt*cos(apl) - ext*sin(apl)
            extp = ezt*sin(apl) + ext*cos(apl)
            ezt = eztp
            ext = extp
            gsc = f(7, ic)/xmat
            bsc = sqrt(1.-1./(gsc*gsc))
            ! omment             cmacrxy=cmacro/(bmoy*bmoy*gmoy*gmoy)
            ! omment             cmacrxy=cmacro/(bsc*bsc*gsc*gsc)
            dxp = const2*ext*dz*cmacrxy*abs(f(9,ic))
            dyp = const2*eyt*dz*cmacrxy*abs(f(9,ic))
            dw = const3*ezt*dz*cmacro*abs(f(9,ic))
            if (.not. iesp) then
              ! load the beam at the input at cavities or gaps
              do js = 1, 7
                f(js, ic) = fs(js, ic)
              end do
              f(3, ic) = f(3, ic) + dxp*1000.
              f(5, ic) = f(5, ic) + dyp*1000.
              f(2, ic) = f(2, ic) - dz1*dxp*100.*xpsc
              f(4, ic) = f(4, ic) - dz1*dyp*100.*xpsc
              ! omment               f(2,ic)=f(2,ic)-dz1*dxp*100.
              ! omment               f(4,ic)=f(4,ic)-dz1*dyp*100.
              dwp(ic) = dw
            else
              f(3, ic) = f(3, ic) + dxp*1000.
              f(5, ic) = f(5, ic) + dyp*1000.
              f(7, ic) = f(7, ic) + dw
            end if
          end if
          ! end of if particle not in mesh
          nprint = nprint + 1
          ! end of the loop ic
        end do
        write (16, *) ' particles in the mesh:', insd, ' outside: ', iout
        ! end of if when ini=2
      end if
      ! 1000   format(4(2x,e12.5))
      return
    end subroutine hersc
    ! *******************************************************************
    ! SUBROUTINE xtypl1(GAMI,SAPHI,QSC,DCG)
    ! called by ETGAP and RESTAY
    ! INTEGRALS  E(z)*(BG)**-3 *z**n   n=0,1
    ! INTEGRALS  dE(z)/dT*(BG)**-3 *z**n   n=0,1,2
    ! INTEGRALS FONCTIONS HA0(Z) et HB0(Z)
    ! INTEGRALS OF THE FIRST DERIVATIVES OF HA0(Z) et HB0(Z)
    ! *******************************************************************
    subroutine xtypl1(gami, saphi, qsc, dcg)
      implicit real *8(a-h, o-z)
      common /consta/vl, pi, xmat, rpel, qst
      common /posi/ist
      common /jacob/gaks, gaps
      common /ttfc/tk, t1k, t2k, sk, s1k, s2k, fh
      common /bedycp/phslip, eqvl, asdl, peqvl, pavph, xkp1, xkp2, aa, bb, cc, dd, ee, pcrest, sqcttf
      common /typl1/yh1k0, yh1k1, yp1k1, yp1k2, yh1k00, yh1k01, yp1k01, yp1k02, yh10, yh11, yp11, yp12
      common /typl2/yh2k0, yh2k1, yp2k1, yp2k2, yh2k00, yh2k01, yp2k01, yp2k02, yh20, yh21, yp21, yp22
      ! TRANSVERSAL dE(z)/dt
      common /typi1/ye1k0, ye1k1, ye1k2, ye1kc0, ye1kc1, ye1kc2, ye10, ye11, ye12
      common /typi2/ye2k0, ye2k1, ye2k2, ye2kc0, ye2kc1, ye2kc2, ye20, ye21, ye22
      dimension h(17), t(17)
      data t/ -.990575473, -.950675522, -.880239154, -.781514004, -.657671159, -.512690537, -.351231763, -.178484181, &
        0., .178484181, .351231763, .512690537, .657671159, .781514004, .880239154, .950675522, .990575473/
      data h/.024148303, .055459529, .085036148, .111883847, .135136368, .154045761, .168004102, .176562705, .179446470, &
        .176562705, .168004102, .154045761, .135136368, .111883847, .085036148, .055459529, .024148303/

      fh0 = fh/vl
      ! valero 08/08/07
      ! omment       CGI=ABS(QSC/XMAT)
      cgi = qsc/xmat
      ! *
      ! Circular cosinus functions
      ! In longitudinal direction
      yh1k0 = 0.
      yh1k1 = 0.
      yp1k1 = 0.
      yp1k2 = 0.
      yh1k00 = 0.
      yh1k01 = 0.
      yp1k01 = 0.
      yp1k02 = 0.
      yh10 = 0.
      yh11 = 0.
      yp11 = 0.
      yp12 = 0.
      ! In transverse direction ( dE(z)/dt )
      ye1k0 = 0.
      ye1k1 = 0.
      ye1k2 = 0.
      ye1kc0 = 0.
      ye1kc1 = 0.
      ye1kc2 = 0.
      ye10 = 0.
      ye11 = 0.
      ye12 = 0.
      ! Circular sinus functions
      ! In longitudinal direction
      yh2k0 = 0.
      yh2k1 = 0.
      yp2k1 = 0.
      yp2k2 = 0.
      yh2k00 = 0.
      yh2k01 = 0.
      yp2k01 = 0.
      yp2k02 = 0.
      yh20 = 0.
      yh21 = 0.
      yp21 = 0.
      yp22 = 0.
      ! In transverse direction ( dE(z)/dt )
      ye2k0 = 0.
      ye2k1 = 0.
      ye2k2 = 0.
      ye2kc0 = 0.
      ye2kc1 = 0.
      ye2kc2 = 0.
      ye20 = 0.
      ye21 = 0.
      ye22 = 0.
      ! Calculates the integrals
      dtilk = eqvl
      gam2 = gami**2
      beti = sqrt(1.-1./gam2)
      xk1 = fh0/beti
      tilta2 = phslip/(2.*eqvl)
      cgam10 = ((gami*gami-1.)**1.5)/fh0
      phcrtk = (t1k*sk-s1k*tk)/(tk*tk+sk*sk)
      ist = 0
      do i = 1, 17
        ist = ist + 1
        xcc = eqvl*(1.+t(i))/2.
        xcc1 = xcc + asdl
        if (xcc1>dcg) go to 200
        phit0 = saphi - phslip*(eqvl-xcc)/(2.*eqvl) + pavph
        ! FONCTION GAMMA (Z)
        if (phslip/=0.) then
          git = cgi*sqcttf*cos(phit0-pcrest)/phslip
          gis = sin(xcc*tilta2)
        else
          git = cgi*sqcttf*cos(phit0-pcrest)
          gis = xcc/(2.*eqvl)
        end if
        gi = gami + git*gis
        bi = sqrt(1.-1./(gi*gi))
        ! Derivative of  G0(Z) relative to the equivalent k
        phit0k = -dtilk*(1.-xcc/eqvl)/2.
        if (phslip/=0.) then
          gic = cos(xcc*tilta2)
          gak1 = dtilk*cos(phit0-pcrest)*gis/(phslip*phslip)
          gak2 = sin(phit0-pcrest)*gis*(phit0k-phcrtk)/phslip
          gak3 = dtilk*cos(phit0-pcrest)*xcc*gic/(2.*phslip*eqvl)
          gak = cgi*sqcttf*(-gak1-gak2+gak3)
        else
          gak1 = sin(phit0-pcrest)*gis*(phit0k-phcrtk)
          gak = -cgi*sqcttf*gak1
        end if
        if (i==17) gaks = gak
        ! Calculate the integrals of  HA0(Z) and HB0(Z)
        xint = 1./(bi*bi*bi*gi*gi*gi)
        phit1 = phit0 + xcc*phslip/(2.*eqvl)
        phtz0 = (xcc/eqvl-.5)*dtilk
        ha0 = 2.*sqcttf*cos(phit1-pcrest)*xint
        hb0 = 2.*sqcttf*sin(phit1-pcrest)*xint
        ! n=0
        ! Longitudinal direction
        yh10 = yh10 + h(i)*ha0
        yh20 = yh20 + h(i)*hb0
        ! Transverse direction
        ye10 = yh20
        ye20 = yh10
        ! n=1
        ! Longitudinal direction
        yh11 = yh11 + h(i)*ha0*xcc1
        yh21 = yh21 + h(i)*hb0*xcc1
        ! Transverse direction
        ye11 = ye11 + h(i)*hb0*xcc
        ye21 = ye21 + h(i)*ha0*xcc
        ! n=2
        ye12 = ye12 + h(i)*hb0*xcc*xcc
        ye22 = ye22 + h(i)*ha0*xcc*xcc
        ! Calculate the integrals of the derivative of HA0(Z)
        dha01 = sqcttf*cos(phit1-pcrest)*gi/((gi*gi-1.)**2.5)
        dha02 = sqcttf*cos(phit1-pcrest)*gi*gak/((gi*gi-1.)**2.5)
        dha03 = sqcttf*sin(phit1-pcrest)/((gi*gi-1.)**1.5)
        ! n=0
        ! Longitudinal direction
        yh1k00 = yh1k00 + h(i)*dha01*6.*cgam10
        yh1k0 = yh1k0 + h(i)*(-6.*dha02+2.*(phcrtk-phtz0)*dha03)
        ! Transverse direction
        ye2kc0 = yh1k00
        ye2k0 = yh1k0
        ! n=1
        ! Longitudinal direction
        yh1k01 = yh1k01 + h(i)*dha01*xcc1*6.*cgam10
        yh1k1 = yh1k1 + h(i)*xcc1*(-6.*dha02+2.*(phcrtk-phtz0)*dha03)
        ! Transverse direction
        ye2kc1 = ye2kc1 + h(i)*dha01*xcc*6.*cgam10
        ye2k1 = ye2k1 + h(i)*xcc*(-6.*dha02-2.*(phcrtk-phtz0)*dha03)
        ! n=2
        ye2kc2 = ye2kc2 + h(i)*dha01*xcc*xcc*6.*cgam10
        ye2k2 = ye2k2 + h(i)*xcc*xcc*(-6.*dha02-2.*(phcrtk-phtz0)*dha03)
        ! INTEGRALS Of  HB0(Z)
        dhb01 = sqcttf*sin(phit1-pcrest)*gi/((gi*gi-1.)**2.5)
        dhb02 = sqcttf*sin(phit1-pcrest)*gi*gak/((gi*gi-1.)**2.5)
        dhb03 = sqcttf*cos(phit1-pcrest)/((gi*gi-1.)**1.5)
        ! n=0
        ! LONGITUDINAL
        yh2k00 = yh2k00 + h(i)*dhb01*6.*cgam10
        yh2k0 = yh2k0 + h(i)*(-6.*dhb02-2.*(phcrtk-phtz0)*dhb03)
        ! TRANSVERSE
        ye1kc0 = yh2k00
        ye1k0 = yh2k0
        ! n=1
        ! LONGITUDINAL
        yh2k01 = yh2k01 + h(i)*dhb01*xcc1*6.*cgam10
        yh2k1 = yh2k1 + h(i)*xcc1*(-6.*dhb02-2.*(phcrtk-phtz0)*dhb03)
        ! TRANSVERSE
        ye1kc1 = ye1kc1 + h(i)*dhb01*xcc*6.*cgam10
        ye1k1 = ye1k1 + h(i)*xcc*(-6.*dhb02-2.*(phcrtk-phtz0)*dhb03)
        ! n=2
        ye1kc2 = ye1kc2 + h(i)*dhb01*xcc*xcc*6.*cgam10
        ye1k2 = ye1k2 + h(i)*xcc*xcc*(-6.*dhb02-2.*(phcrtk-phtz0)*dhb03)
        ! Calculate the integrals of PA0(Z) et PB0(Z)
        pa0 = 2.*sqcttf*cos(phit1-pcrest)*xint*xint
        pb0 = 2.*sqcttf*sin(phit1-pcrest)*xint*xint
        ! n=1
        yp11 = yp11 + h(i)*pa0*xcc1
        yp21 = yp21 + h(i)*pb0*xcc1
        ! n=2
        yp12 = yp12 + h(i)*pa0*xcc1*xcc1
        yp22 = yp22 + h(i)*pb0*xcc1*xcc1
        ! Calculate the integrals of the derivatives of PA0(Z)
        dpa01 = sqcttf*cos(phit1-pcrest)*gi/((gi*gi-1.)**4)
        dpa02 = sqcttf*cos(phit1-pcrest)*gi*gak/((gi*gi-1.)**4)
        dpa03 = sqcttf*sin(phit1-pcrest)/((gi*gi-1.)**3)
        ! n=1
        yp1k01 = yp1k01 + h(i)*dpa01*12.*cgam10*xcc1
        yp1k1 = yp1k1 + h(i)*xcc1*(-12.*dpa02+2.*(phcrtk-phtz0)*dpa03)
        ! n=2
        yp1k02 = yp1k02 + h(i)*dpa01*12.*cgam10*xcc1*xcc1
        yp1k2 = yp1k2 + h(i)*xcc1*xcc1*(-12.*dpa02+2.*(phcrtk-phtz0)*dpa03)
        ! INTEGRALES DERIVES PB0(Z)
        dpb01 = sqcttf*sin(phit1-pcrest)*gi/((gi*gi-1.)**4)
        dpb02 = sqcttf*sin(phit1-pcrest)*gi*gak/((gi*gi-1.)**4)
        dpb02 = dpb02
        dpb03 = sqcttf*cos(phit1-pcrest)/((gi*gi-1.)**3)
        ! n=1
        yp2k01 = yp2k01 + h(i)*dpb01*12.*cgam10*xcc1
        yp2k1 = yp2k1 + h(i)*xcc1*(-12.*dpb02-2.*(phcrtk-phtz0)*dpb03)
        ! n=2
        yp2k02 = yp2k02 + h(i)*dpb01*12.*cgam10*xcc1*xcc1
        yp2k2 = yp2k2 + h(i)*xcc1*xcc1*(-12.*dpb02-2.*(phcrtk-phtz0)*dpb03)
      end do
200   continue
      ! in COS
      ! LONGITUDINAL INTEGRALS
      yh1k00 = yh1k00/2.*eqvl
      yh1k01 = yh1k01/2.*eqvl
      yh1k0 = yh1k0/2.*eqvl
      yh1k1 = yh1k1/2.*eqvl
      yp1k1 = yp1k1/2.*eqvl
      yp1k2 = yp1k2/2.*eqvl
      yp1k01 = yp1k01/2.*eqvl
      yp1k02 = yp1k02/2.*eqvl
      yh10 = yh10*eqvl/2.
      yh11 = yh11*eqvl/2.
      yp11 = yp11*eqvl/2.
      yp12 = yp12*eqvl/2.
      ! Transverse integrals
      ye1k0 = ye1k0/2.*eqvl
      ye1kc0 = ye1kc0/2.*eqvl
      ye1k1 = ye1k1/2.*eqvl
      ye1kc1 = ye1kc1/2.*eqvl
      ye1k2 = ye1k2/2.*eqvl
      ye1kc2 = ye1kc2/2.*eqvl
      ye10 = ye10*eqvl/2.
      ye11 = ye11*eqvl/2.
      ye12 = ye12*eqvl/2.
      ! in SIN
      ! LONGITUDINAL INTEGRALS
      yh2k00 = yh2k00/2.*eqvl
      yh2k01 = yh2k01/2.*eqvl
      yh2k0 = yh2k0/2.*eqvl
      yh2k1 = yh2k1/2.*eqvl
      yp2k1 = yp2k1/2.*eqvl
      yp2k2 = yp2k2/2.*eqvl
      yp2k01 = yp2k01/2.*eqvl
      yp2k02 = yp2k02/2.*eqvl
      yh20 = yh20*eqvl/2.
      yh21 = yh21*eqvl/2.
      yp21 = yp21*eqvl/2.
      yp22 = yp22*eqvl/2.
      ! TRANSVERSE INTEGRALS
      ye2k0 = ye2k0/2.*eqvl
      ye2kc0 = ye2kc0/2.*eqvl
      ye2k1 = ye2k1/2.*eqvl
      ye2kc1 = ye2kc1/2.*eqvl
      ye2k2 = ye2k2/2.*eqvl
      ye2kc2 = ye2kc2/2.*eqvl
      ye20 = ye20*eqvl/2.
      ye21 = ye21*eqvl/2.
      ye22 = ye22*eqvl/2.
      ! 100    CONTINUE
      return
    end subroutine xtypl1
    ! *******************************************************************
    ! SUBROUTINE chasel
    ! analysis of emittance by elimination of remote particles in the
    ! z-direction
    ! *******************************************************************
    subroutine chasel
      implicit real *8(a-h, o-z)
      parameter(iptsz=100002, maxcell=3000, maxcell1=3000)
      common /ttfc/tk, t1k, t2k, sk, s1k, s2k, fh
      common /fene/wdisp, wphas, wx, wy, rlim, ifw
      common /faisc/f(10, iptsz), imax, ngood
      common /qmoyen/qmoy
      common /consta/vl, pi, xmat, rpel, qst
      common /tapes/in, ifile, meta
      common /etcha1/dav2(maxcell1, 33), ichas(iptsz), chasit
      logical chasit
      common /etchas/fractx, fracty, fractl
      common /etcom/cog(8), exten(17), fd(iptsz)
      common /pool/zl(iptsz), ipin(iptsz)

      if (fractl>=1.) return
      do i = 1, ngood
        ichas(i) = 1
        zl(i) = 0.
        ipin(i) = 1
      end do
      nl = int(float(ngood)*fractl)
      inz = 0
      imaxf = ngood
      inx = 0
      ! ellipsoid of concentration (phase-dispersion)
      tx2 = 0.
      txp2 = 0.
      txxp = 0.
      do i = 1, ngood
        tx2 = tx2 + f(6, i)*f(6, i)
        txp2 = txp2 + fd(i)*fd(i)
        txxp = txxp + f(6, i)*fd(i)
      end do
      tx2 = tx2/float(ngood)
      txp2 = txp2/float(ngood)
      txxp = txxp/float(ngood)
      delxxp = tx2*txp2 - txxp*txxp
      ikept = 0
      do i = 1, ngood
        theta = pi/2.
        if (fd(i)/=0.) theta = atan(f(6,i)/fd(i))
        rpart = f(6, i)*f(6, i) + fd(i)*fd(i)
        cos2 = cos(theta)*cos(theta)
        sin2 = sin(theta)*sin(theta)
        denom = tx2*cos2 + txp2*sin2 - 2.*txxp*cos(theta)*sin(theta)
        relpse = 2.5*delxxp/denom
        if (fractl>=.97) then
          relpse = 3.5*delxxp/denom
        else
          if (fractl>=.95) relpse = 3.*delxxp/denom
        end if
        if (rpart<=relpse) then
          ipin(i) = 0
          ikept = ikept + 1
        end if
      end do
      write (16, *) ' CHASEL:', fractl, '  % over: ', ngood - ikept, ' particles'
      do j = 1, ngood
        if (ipin(j)==1) then
          inz = inz + 1
          if (imaxf<=nl) go to 9990
          imaxx = 0
          tx = 0.
          txp = 0.
          txxp = 0.
          tx2 = 0.
          txp2 = 0.
          do i = 1, ngood
            if (ichas(i)==1) then
              tx = f(6, i) + tx
              txp = fd(i) + txp
              tx2 = tx2 + f(6, i)*f(6, i)
              txp2 = txp2 + fd(i)*fd(i)
              txxp = txxp + f(6, i)*fd(i)
              imaxx = imaxx + 1
            end if
          end do
          tx = tx/float(imaxx)
          txp = txp/float(imaxx)
          tx2 = tx2/float(imaxx)
          txp2 = txp2/float(imaxx)
          txxp = txxp/float(imaxx)
          xcg = tx
          zcg = txp
          ! betatron parameters
          xxl = tx2 - tx*tx
          zzl = txp2 - txp*txp
          xzl = txxp - tx*txp
          if (inz==1) go to 8880
          flcrit = 2.*fl2rms*log(2.*imaxx)
          if (zlma<flcrit) go to 7770
8880      emil = sqrt(xxl*zzl-xzl*xzl)
          if (emil==0.) then
            al = 0.
            bl = 0.
            cl = 0.
          else
            bl = sqrt(xxl/emil)
            cl = 1./bl
            al = -xzl/emil
          end if
          tlx0 = tx
          tlz0 = txp
7770      fl2rms = (1.+al*al)*xxl/bl + 2.*al*xzl + bl*zzl
          zlma = 0.
          do i = 1, ngood
            zl(i) = 0.
            if (ichas(i)==1) then
              psx = f(6, i) - tlx0
              psz = fd(i) - tlz0
              zl(i) = psx*psx*cl*cl + (psx*al/bl+psz*bl)**2
              if (zlma<zl(i)) then
                zlma = zl(i)
                izlma = i
              end if
            end if
          end do
          ! particle is eliminated
          imaxf = 0
          if (zlma==0.) zlma = 1.e10
          do i = 1, ngood
            if (ichas(i)==1 .and. zl(i)<zlma) then
              imaxf = imaxf + 1
            else
              ichas(i) = 0
            end if
          end do
        end if
      end do
9990  continue
      return
    end subroutine chasel
    ! *******************************************************************
    ! SUBROUTINE chasex
    ! analysis of emittance by elimination of remote particles in the
    ! x-direction
    ! *******************************************************************
    subroutine chasex
      implicit real *8(a-h, o-z)
      parameter(iptsz=100002, maxcell=3000, maxcell1=3000)
      common /ttfc/tk, t1k, t2k, sk, s1k, s2k, fh
      common /fene/wdisp, wphas, wx, wy, rlim, ifw
      common /faisc/f(10, iptsz), imax, ngood
      common /qmoyen/qmoy
      common /consta/vl, pi, xmat, rpel, qst
      common /tapes/in, ifile, meta
      common /etcha1/dav2(maxcell1, 33), ichas(iptsz), chasit
      logical chasit
      common /etchas/fractx, fracty, fractl
      common /pool/zl(iptsz), ipin(iptsz)

      if (fractx>=1.) return
      do i = 1, ngood
        ichas(i) = 1
        zl(i) = 0.
        ipin(i) = 1
      end do
      nl = int(float(ngood)*fractx)
      inz = 0
      imaxf = ngood
      inx = 0
      ! ellipsoid of concentration (x-xp)
      tx2 = 0.
      txp2 = 0.
      txxp = 0.
      do i = 1, ngood
        f2 = f(2, i)*1.e-02
        f3 = f(3, i)*1.e-03
        tx2 = tx2 + f2*f2
        txp2 = txp2 + f3*f3
        txxp = txxp + f2*f3
      end do
      tx2 = tx2/float(ngood)
      txp2 = txp2/float(ngood)
      txxp = txxp/float(ngood)
      delxxp = tx2*txp2 - txxp*txxp
      ikept = 0
      do i = 1, ngood
        theta = pi/2.
        f2 = f(2, i)*1.e-02
        f3 = f(3, i)*1.e-03
        if (f3/=0.) theta = atan(f2/f3)
        rpart = f2*f2 + f3*f3
        cos2 = cos(theta)*cos(theta)
        sin2 = sin(theta)*sin(theta)
        denom = tx2*cos2 + txp2*sin2 - 2.*txxp*cos(theta)*sin(theta)
        relpse = 2.5*delxxp/denom
        if (fractx>=.97) then
          relpse = 3.5*delxxp/denom
        else
          if (fractx>=.95) relpse = 3.*delxxp/denom
        end if
        if (rpart<=relpse) then
          ipin(i) = 0
          ikept = ikept + 1
        end if
      end do
      write (16, *) ' CHASEX:', fractx, '  % over: ', ngood - ikept, ' particles'
      do j = 1, ngood
        if (ipin(j)==1) then
          inz = inz + 1
          if (imaxf<=nl) go to 9990
          imaxx = 0
          tx = 0.
          txp = 0.
          txxp = 0.
          tx2 = 0.
          txp2 = 0.
          do i = 1, ngood
            if (ichas(i)==1) then
              tx = f(2, i) + tx
              txp = f(3, i) + txp
              tx2 = tx2 + f(2, i)*f(2, i)
              txp2 = txp2 + f(3, i)*f(3, i)
              txxp = txxp + f(2, i)*f(3, i)
              imaxx = imaxx + 1
            end if
          end do
          tx = tx/float(imaxx)
          txp = txp/float(imaxx)
          tx2 = tx2/float(imaxx)
          txp2 = txp2/float(imaxx)
          txxp = txxp/float(imaxx)
          xcg = tx
          zcg = txp
          ! betatron parameters
          xxl = tx2 - tx*tx
          zzl = txp2 - txp*txp
          xzl = txxp - tx*txp
          if (inz==1) go to 8880
          flcrit = 2.*fl2rms*log(2.*imaxx)
          if (zlma<flcrit) go to 7770
8880      emil = sqrt(xxl*zzl-xzl*xzl)
          if (emil==0.) then
            al = 0.
            bl = 0.
            cl = 0.
          else
            bl = sqrt(xxl/emil)
            cl = 1./bl
            al = -xzl/emil
          end if
          tlx0 = tx
          tlz0 = txp
7770      fl2rms = (1.+al*al)*xxl/bl + 2.*al*xzl + bl*zzl
          zlma = 0.
          do i = 1, ngood
            zl(i) = 0.
            if (ichas(i)==1) then
              psx = f(2, i) - tlx0
              psz = f(3, i) - tlz0
              zl(i) = psx*psx*cl*cl + (psx*al/bl+psz*bl)**2
              if (zlma<zl(i)) then
                zlma = zl(i)
                izlma = i
              end if
            end if
          end do
          ! particle is eliminated
          imaxf = 0
          if (zlma==0.) zlma = 1.e10
          do i = 1, ngood
            if (ichas(i)==1 .and. zl(i)<zlma) then
              imaxf = imaxf + 1
            else
              ichas(i) = 0
            end if
          end do
        end if
      end do
9990  continue
      return
    end subroutine chasex
    ! *******************************************************************
    ! SUBROUTINE chase
    ! analysis of emittance by elimination of remote particles
    ! read the parameters and print them out
    ! *******************************************************************
    subroutine chase
      implicit real *8(a-h, o-z)
      parameter(iptsz=100002, maxcell=3000, maxcell1=3000)
      common /tapes/in, ifile, meta
      common /etchas/fractx, fracty, fractl
      common /etcha1/dav2(maxcell1, 33), ichas(iptsz), chasit
      logical chasit

      read (in, *) fractx, fracty, fractl
      write (16, 1) fractx*100., fracty*100., fractl*100.
1     format ('    ARE KEPT IN THE BUNCH ', /, '       (x,xp)   : ', f7.3, ' %', /, '       (y,yp)   : ', f7.3, ' % ', &
        /, '       (w,phase):', f7.3, ' %')

      chasit = .false.
      if (fractx<1.) chasit = .true.
      if (fracty<1.) chasit = .true.
      if (fractl<1.) chasit = .true.
      return
    end subroutine chase
    ! *******************************************************************
    ! SUBROUTINE chasey
    ! analysis of emittance by elimination of remote particles in the
    ! y-direction
    ! *******************************************************************
    subroutine chasey
      implicit real *8(a-h, o-z)
      parameter(iptsz=100002, maxcell=3000, maxcell1=3000)
      common /ttfc/tk, t1k, t2k, sk, s1k, s2k, fh
      common /fene/wdisp, wphas, wx, wy, rlim, ifw
      common /faisc/f(10, iptsz), imax, ngood
      common /qmoyen/qmoy
      common /consta/vl, pi, xmat, rpel, qst
      common /tapes/in, ifile, meta
      common /etcha1/dav2(maxcell1, 33), ichas(iptsz), chasit
      logical chasit
      common /etchas/fractx, fracty, fractl
      common /pool/zl(iptsz), ipin(iptsz)

      if (fracty>=1.) return
      do i = 1, ngood
        ichas(i) = 1
        zl(i) = 0.
        ipin(i) = 1
      end do
      ! ellipsoid of concentration (y-yp)
      ty2 = 0.
      typ2 = 0.
      tyyp = 0.
      do i = 1, ngood
        f4 = f(4, i)*1.e-02
        f5 = f(5, i)*1.e-03
        ty2 = ty2 + f4*f4
        typ2 = typ2 + f5*f5
        tyyp = tyyp + f4*f5
      end do
      ty2 = ty2/float(ngood)
      typ2 = typ2/float(ngood)
      tyyp = tyyp/float(ngood)
      delyyp = ty2*typ2 - tyyp*tyyp
      ikept = 0
      do i = 1, ngood
        f4 = f(4, i)*1.e-02
        f5 = f(5, i)*1.e-03
        theta = pi/2.
        if (f5/=0.) theta = atan(f4/f5)
        rpart = f4*f4 + f5*f5
        cos2 = cos(theta)*cos(theta)
        sin2 = sin(theta)*sin(theta)
        denom = ty2*cos2 + typ2*sin2 - 2.*tyyp*cos(theta)*sin(theta)
        relpse = 2.5*delyyp/denom
        if (fracty>=.97) then
          relpse = 3.5*delyyp/denom
        else
          if (fracty>=.95) relpse = 3.*delyyp/denom
        end if
        if (rpart<=relpse) then
          ipin(i) = 0
          ikept = ikept + 1
        end if
      end do
      write (16, *) ' CHASEY:', fracty, '  % over: ', ngood - ikept, ' particles'
      imaxf = ngood
      nl = int(float(ngood)*fracty)
      inz = 0
      do j = 1, ngood
        if (ipin(j)==1) then
          inz = inz + 1
          if (imaxf<=nl) go to 9990
          imaxx = 0
          ty = 0.
          typ = 0.
          tyyp = 0.
          ty2 = 0.
          typ2 = 0.
          do i = 1, ngood
            if (ichas(i)==1) then
              ty = f(4, i) + ty
              typ = f(5, i) + typ
              ty2 = ty2 + f(4, i)*f(4, i)
              typ2 = typ2 + f(5, i)*f(5, i)
              tyyp = tyyp + f(4, i)*f(5, i)
              imaxx = imaxx + 1
            end if
          end do
          ty = ty/float(imaxx)
          typ = typ/float(imaxx)
          ty2 = ty2/float(imaxx)
          typ2 = typ2/float(imaxx)
          tyyp = tyyp/float(imaxx)
          xcg = ty
          zcg = typ
          ! betatron parameters
          xxl = ty2 - ty*ty
          zzl = typ2 - typ*typ
          xzl = tyyp - ty*typ
          if (inz==1) go to 8880
          flcrit = 2.*fl2rms*log(2.*imaxx)
          if (zlma<flcrit) go to 7770
8880      emil = sqrt(xxl*zzl-xzl*xzl)
          if (emil==0.) then
            al = 0.
            bl = 0.
            cl = 0.
          else
            bl = sqrt(xxl/emil)
            cl = 1./bl
            al = -xzl/emil
          end if
          tlx0 = ty
          tlz0 = typ
7770      fl2rms = (1.+al*al)*xxl/bl + 2.*al*xzl + bl*zzl
          zlma = 0.
          do i = 1, ngood
            zl(i) = 0.
            if (ichas(i)==1) then
              psx = f(4, i) - tlx0
              psz = f(5, i) - tlz0
              zl(i) = psx*psx*cl*cl + (psx*al/bl+psz*bl)**2
              if (zlma<zl(i)) then
                zlma = zl(i)
                izlma = i
              end if
            end if
          end do
          ! particle is eliminated
          imaxf = 0
          if (zlma==0.) zlma = 1.e10
          do i = 1, ngood
            if (ichas(i)==1 .and. zl(i)<zlma) then
              imaxf = imaxf + 1
            else
              ichas(i) = 0
            end if
          end do
        end if
      end do
9990  continue
      return
    end subroutine chasey
    ! *******************************************************************
    ! SUBROUTINE corre(n,nall)
    ! correction over the beam generated by MONTE
    ! *******************************************************************
    subroutine corre(n, nall)
      implicit real *8(a-h, o-z)
      parameter(iptsz=100002, maxcell=3000, maxcell1=3000)
      common /com4/cord(iptsz, 6)
      dimension a(6, 6), b(6, 6), c(6, 6), d(6), e(6), f(6), g(6)

      do i = 1, 6
        d(i) = 0.0
        e(i) = 0.0
        f(i) = 0.0
        g(i) = 0.0
        do j = 1, 6
          a(i, j) = 0.0
          b(i, j) = 0.0
          c(i, j) = 0.0
        end do
      end do
      do j = 1, 6
        do i = 1, n
          d(j) = d(j) + cord(i, j)
        end do
        d(j) = d(j)/n
      end do
      do j = 1, 6
        do i = 1, nall
          cord(i, j) = cord(i, j) - d(j)
        end do
      end do
      do j = 1, 6
        do k = 1, j
          do i = 1, n
            a(j, k) = a(j, k) + cord(i, j)*cord(i, k)
          end do
          a(j, k) = a(j, k)/n
        end do
      end do
      ! WE MAKE MATRIX A=B*BT WHERE B,BT ARE TRIANGULAR
      do i = 1, 6
        do j = 1, i
          h = a(i, j)
          j1 = j - 1
          if (j==1) go to 8
          do k = 1, j1
            h = h - a(i, k)*a(j, k)
          end do
8         if (i==j) go to 10
          a(i, j) = h/a(j, j)
          go to 7
10        a(i, j) = sqrt(h)
7         b(i, j) = a(i, j)
        end do
      end do
      ! WE INVERT B TO GIVE AN UPDATED B
      e(1) = 1.0/b(1, 1)
      do i = 2, 6
        e(i) = 1.0/b(i, i)
        j1 = i - 1
        do jj = 1, j1
          j = i - jj
          j3 = j + 1
          s = 0.0
          if (jj==1) go to 13
          do k = j3, j1
            s = s - b(k, i)*b(k, j)
          end do
13        b(j, i) = (s-b(i,j)*e(i))/b(j, j)
        end do
      end do
      do i = 1, 6
        b(i, i) = e(i)
      end do
      do i = 1, 6
        do j = 1, i
          dum = b(i, j)
          b(i, j) = b(j, i)
          b(j, i) = dum
        end do
      end do
      ! WE CONVERT CORD(**) SO THAT ITS SIGMA MATRIX IS UNITY
      do i = 1, nall
        do k = 1, 6
          f(k) = 0.0
          do j = 1, k
            f(k) = f(k) + b(k, j)*cord(i, j)
          end do
        end do
        do k = 1, 6
          cord(i, k) = f(k)
        end do
      end do
      ! WE TEST THE MEANS AND SIGMA MATRIX
      do j = 1, 6
        do i = 1, n
          g(j) = g(j) + cord(i, j)
        end do
        g(j) = g(j)/n
      end do
      do j = 1, 6
        do i = 1, n
          cord(i, j) = cord(i, j) - g(j)
        end do
      end do
      do j = 1, 6
        do k = 1, 6
          do i = 1, n
            c(j, k) = c(j, k) + cord(i, j)*cord(i, k)
          end do
          c(j, k) = c(j, k)/n
        end do
      end do
      return
    end subroutine corre
    ! *******************************************************************
    ! SUBROUTINE pintim
    ! Shifts particle coordinates to a single point in time. Uses a
    ! linear shift Divide by 100 to convert from cm to meters
    ! called by SCHEFF or SCHERM
    ! *******************************************************************
    subroutine pintim
      implicit real *8(a-h, o-z)
      parameter(iptsz=100002, maxcell=3000, maxcell1=3000)
      common /faisc/f(10, iptsz), imax, ngood
      common /qmoyen/qmoy
      common /part/xc(iptsz), yc(iptsz), zc(iptsz)
      common /consta/vl, pi, xmat, rpel, qst
      common /sc3/beamc, scdist, sce10, cplm, ect, apl, ichaes, iscsp
      common /azlist/icont, iprin

      grmoy = 0.
      trmoy = 0.
      xbax = 0.
      do i = 1, ngood
        grmoy = grmoy + f(7, i)/xmat
        trmoy = trmoy + f(6, i)
        xbax = xbax + f(2, i)
      end do
      trmoy = trmoy/float(ngood)
      grmoy = grmoy/float(ngood)
      brmoy = sqrt(1.-1./(grmoy*grmoy))
      xbax = xbax/float(ngood)
      apl = 0.
      ! Isochronism correction  (bending magnet) only with SCHERM
      ! does not work with  with SCHEFF  (iscsp=3)
      if (iscsp==2) then
        xb2x = 0.
        xb2z = 0.
        xbxz = 0.
        do np = 1, ngood
          gpai = f(7, np)/xmat
          bpai = sqrt(1.-1./(gpai*gpai))
          zc(np) = (trmoy-f(6,np))*bpai*vl/100.
          xc(np) = (f(2,np)-xbax)/100.
          xb2z = xb2z + zc(np)*zc(np)
          xb2x = xb2x + xc(np)*xc(np)
          xbxz = xbxz + zc(np)*xc(np)
        end do
        xb2z = xb2z/float(ngood)
        xb2x = xb2x/float(ngood)
        xbxz = xbxz/float(ngood)
        apl = atan(-2.*xbxz/(xb2x-xb2z))/2.
        write (16, *) 'slope of the bunch in plane(Oz,Ox):', apl, ' radian'
      end if
      do np = 1, ngood
        gpai = f(7, np)/xmat
        bpai = sqrt(1.-1./(gpai*gpai))
        ! iscsp = 3 Lorentz transformation (only with scheff)
        ! omment         if(iscsp.eq.3) znp=(trmoy-f(6,np))*bpai*vl*grmoy
        ! omment         if(iscsp.eq.2) znp=(trmoy-f(6,np))*bpai*vl
        znp = (trmoy-f(6,np))*bpai*vl
        xnp = f(2, np)
        zc(np) = znp*cos(apl) + xnp*sin(apl)
        xnp = xnp*cos(apl) - znp*sin(apl)
        ! convert from mrad to rad
        f3 = f(3, np)*1.e-03
        f5 = f(5, np)*1.e-03
        ! convert from cm   to m
        xc(np) = (xnp+zc(np)*f3)/100.
        yc(np) = (f(4,np)+zc(np)*f5)/100.
        zc(np) = zc(np)/100.
      end do
      xbar = 0.
      ybar = 0.
      zbar = 0.
      do np = 1, ngood
        ! evaluate xbar , ybar , zbar
        xbar = xbar + xc(np)
        ybar = ybar + yc(np)
        zbar = zbar + zc(np)
      end do
      xbar = xbar/float(ngood)
      ybar = ybar/float(ngood)
      zbar = zbar/float(ngood)
      ! Translate distribution by center of mass coordinates to shift
      ! coordinate origin to (0,0,0)
      do np = 1, ngood
        xc(np) = xc(np) - xbar
        yc(np) = yc(np) - ybar
        zc(np) = zc(np) - zbar
      end do
      return
    end subroutine pintim
    ! *******************************************************************
    ! SUBROUTINE schermi1
    ! Called by SCHERMI when the bunch can be represented
    ! by a simple ellipse in the longitudinal direction
    ! *******************************************************************
    subroutine schermi1
      implicit real *8(a-h, o-z)
      parameter(iptsz=100002, maxcell=3000, maxcell1=3000)
      common /ttfc/tk, t1k, t2k, sk, s1k, s2k, fh
      common /hermt/afxt(22), afyt(22), afzt(22)
      common /hermd/afxm(20), afym(20), afzm(20)
      common /hermr/afxr(20), afyr(20), afzr(20)
      common /sizt/xrms, yrms, zrms
      common /sizp/xrms1, yrms1, zrms1, xrms2, yrms2, zrms2, imaxd
      common /elcg/xcgd, ycgd, zcgd, xcgr, ycgr, zcgr
      common /intgrt/ex, ey, ez
      common /degherm/nmaz, nmazr, nmaxy
      common /cdek/dwp(iptsz)
      common /consta/vl, pi, xmat, rpel, qst
      common /faisc/f(10, iptsz), imax, ngood
      common /sc3/beamc, scdist, sce10, cplm, ect, apl, ichaes, iscsp
      common /npart/imaxr
      common /part/xc(iptsz), yc(iptsz), zc(iptsz)
      common /twcst/epsilon
      common /beamsa/fs(7, iptsz)
      common /dcspa/iesp
      common /cmpte/iell
      common /cgrms/xsum, ysum, zsum
      common /compt/nrres, nrtre, nrbunc, nrdbun
      common /dimens/zcp(iptsz), xcp(iptsz), ycp(iptsz)
      common /posc/xpsc
      logical ichaes, iesp
      dimension afx(20), afy(20)

      if (beamc==0. .or. scdist==0.) return
      iell = iell + 1
      imaxf = ngood
      wavel = 2.*pi*vl/fh
      xmass = xmat*1.78267581e-30
      nmaxy = 5
      dxp = 0.
      dyp = 0.
      dw = 0.
      dz = scdist/100.
      dz1 = dz
      if (ngood==0) then
        write (16, *) ' all the particles are lost '
        stop
      end if
      ! xi in Amps, beamc in mA
      ! epsilon =(coul*coul)/nt*(m*m)
      epsilon = 8.854189586e-12
      c1 = 1./(3.*pi*sqrt(5.))
      cl = vl/100.
      ! charge per macro particle
      ! omment       const1=c1*xi*xi*wavel*wavel/(10000.*imaxf*xmass*
      ! *         epsilon*cl*cl*cl*cl)
      const3 = 1.e-06
      const2 = 1.e-06/xmat
      ! calculate rms beam size for beam in one point in time
      call sizrms(0, xrms, yrms, zrms, zz)
      ! 6875   format(2x,e12.5,2x,e12.5,2x,e12.5)
      xrmsp = xrms
      yrmsp = yrms
      zrmsp = zrms
      call sizcor(ect, xrms, yrms, zrms, 0)
      xrmsc = xrms
      yrmsc = yrms
      zrmsc = zrms
      xrms1 = xrmsp
      yrms1 = yrmsp
      zrms1 = zrmsp
      xrms = xrmsp
      yrms = yrmsp
      zrms = zrmsp
      xcgd = xsum
      ycgd = ysum
      zcgd = zsum
      do i = 1, ngood
        zcp(i) = zc(i)
        xcp(i) = xc(i)
        ycp(i) = yc(i)
      end do
      ! limits in z-direction
      zmat = 0.
      zmit = 1000.
      do i = 1, ngood
        if (zcp(i)>=zmat) zmat = zcp(i)
        if (zcp(i)<zmit) zmit = zcp(i)
      end do
      zmat = zmat/zrms
      zmit = zmit/zrms
      ! extends zmat
      zmat = zmat + zmat*.50
      zmit = zmit + zmit*.50
      if (zmat>ect) zmat = ect
      if (abs(zmit)>ect) zmit = -ect
      ! Hermite coefficients in x and y-direction
      nmaz = 0
      ! 6876   format(2x,i3,2x,i3)
      do k = 1, 20
        afzt(k) = 0.
        afxt(k) = 0.
        afyt(k) = 0.
        afzm(k) = 0.
        afxm(k) = 0.
        afym(k) = 0.
      end do
      do k = 1, nmaxy
        kap = k - 1
        do j = 1, ngood
          xcoup = abs(xcp(j)/xrms)
          ycoup = abs(ycp(j)/yrms)
          zcoup = abs(zcp(j)/zrms)
          if (xcoup<=ect .and. ycoup<=ect .and. zcoup<=ect) then
            xc(j) = xcp(j)/xrmsc
            yc(j) = ycp(j)/yrmsc
            zc(j) = zcp(j)/zrmsc
            afxm(k) = afxm(k) + herm(2*kap, xc(j))
            afym(k) = afym(k) + herm(2*kap, yc(j))
            afzm(k) = afzm(k) + herm(2*kap, zc(j))
          end if
        end do
        afxm(k) = afxm(k)/(fact(2*kap)*sqrt(2.*pi))
        afym(k) = afym(k)/(fact(2*kap)*sqrt(2.*pi))
        afzm(k) = afzm(k)/(fact(2*kap)*sqrt(2.*pi))
      end do
      nmaz = 10
      ! Hermite coefficients in z-direction
      zcdg = 0.
      imaxx = 0
      do j = 1, ngood
        xcoup = abs(xcp(j)/xrms)
        ycoup = abs(ycp(j)/yrms)
        zcoup = abs(zcp(j)/zrms)
        if (xcoup<=ect .and. ycoup<=ect .and. zcoup<=ect) then
          zcdg = zcdg + zcp(j)
          imaxx = imaxx + 1
        end if
      end do
      zcdg = zcdg/float(imaxx)
      zsqsum = 0.
      zcub = 0.
      zcub1 = 0.
      do j = 1, ngood
        xcoup = abs(xcp(j)/xrms)
        ycoup = abs(ycp(j)/yrms)
        zcoup = abs(zcp(j)/zrms)
        if (xcoup<=ect .and. ycoup<=ect .and. zcoup<=ect) then
          zc(j) = zcp(j) - zcdg
          zsqsum = zsqsum + zc(j)*zc(j)
          zcub = zcub + zc(j)*zc(j)*zc(j)
          zcub1 = zcub1 + zc(j)
        end if
      end do
      zrmsz = zsqsum/float(imaxx)
      zrmsz = sqrt(zrmsz)
      zcub3 = zcub
      zcub = zcub/(zrmsz*zrmsz*zrmsz) - 3.*zcub1/zrmsz
      zcub = zcub/(6.*sqrt(2.*pi))
      do k = 1, nmaz
        afzt(k) = 0.
        afx(k) = 0.
        afy(k) = 0.
        kap = k - 1
        do j = 1, ngood
          xcoup = abs(xcp(j)/xrms)
          ycoup = abs(ycp(j)/yrms)
          zcoup = abs(zcp(j)/zrms)
          if (xcoup<=ect .and. ycoup<=ect .and. zcoup<=ect) then
            zc(j) = zcp(j)/zrmsc
            xc(j) = xcp(j)/xrmsc
            yc(j) = ycp(j)/yrmsc
            afzt(k) = afzt(k) + herm(kap, zc(j))
            afx(k) = afx(k) + herm(kap, xc(j))
            afy(k) = afy(k) + herm(kap, yc(j))
          end if
        end do
        afzt(k) = afzt(k)/(fact(kap)*sqrt(2.*pi))
        afx(k) = afx(k)/(fact(kap)*sqrt(2.*pi))
        afy(k) = afy(k)/(fact(kap)*sqrt(2.*pi))
      end do
      ! Do Hermite integration to determine Ex,Ey,Ez for each macro particle
      ! and apply space charge kick. Field components are passed through the
      ! common INTGRT in units Newton/Coulomb
      do i = 1, ngood
        ! reprise coordonnees spaciales pour calcul des champs
        xc(i) = xcp(i)
        yc(i) = ycp(i)
        zc(i) = zcp(i)
        call intga(i, 0)
        ext = ex
        eyt = ey
        ezt = ez
        ! calculate kick in x',y' and z' (energy)
        ! calculate kick in x',y' and z' (energy)
        ! isochronism correction
        eztp = ezt*cos(apl) - ext*sin(apl)
        extp = ezt*sin(apl) + ext*cos(apl)
        ezt = eztp
        ext = extp
        gsc = f(7, i)/xmat
        bsc = sqrt(1.-1./(gsc*gsc))
        ! *  valero
        dxp = const2*ext*dz/(bsc*bsc*gsc*gsc*gsc)*abs(f(9,i))
        dyp = const2*eyt*dz/(bsc*bsc*gsc*gsc*gsc)*abs(f(9,i))
        dw = const3*ezt*dz*abs(f(9,i))/gsc
        ! *
        if (.not. iesp) then
          ! load the entrance beam in cavities or gaps
          do js = 1, 7
            f(js, i) = fs(js, i)
          end do
          f(3, i) = f(3, i) + dxp*1000.
          f(5, i) = f(5, i) + dyp*1000.
          f(2, i) = f(2, i) - dz1*dxp*100.*xpsc
          f(4, i) = f(4, i) - dz1*dyp*100.*xpsc
          dwp(i) = dw
        else
          f(3, i) = f(3, i) + dxp*1000.
          f(5, i) = f(5, i) + dyp*1000.
          f(7, i) = f(7, i) + dw
        end if
      end do
      return
    end subroutine schermi1
    ! *******************************************************************
    ! SUBROUTINE schermi
    ! SCHERM space charge method
    ! See NIM A 309(1996) 21-40
    ! *******************************************************************
    subroutine schermi
      implicit real *8(a-h, o-z)
      parameter(iptsz=100002, maxcell=3000, maxcell1=3000)
      common /ttfc/tk, t1k, t2k, sk, s1k, s2k, fh
      common /hermt/afxt(22), afyt(22), afzt(22)
      common /hermd/afxm(20), afym(20), afzm(20)
      common /hermr/afxr(20), afyr(20), afzr(20)
      common /hermrr/afxrr(20), afyrr(20), afzrr(20)
      common /sizr/xrms3, yrms3, zrms3, zcgr3
      common /sizt/xrms, yrms, zrms
      common /sizp/xrms1, yrms1, zrms1, xrms2, yrms2, zrms2, imaxd
      common /elcg/xcgd, ycgd, zcgd, xcgr, ycgr, zcgr
      common /intgrt/ex, ey, ez
      common /degherm/nmaz, nmazr, nmaxy
      common /cdek/dwp(iptsz)
      common /consta/vl, pi, xmat, rpel, qst
      common /faisc/f(10, iptsz), imax, ngood
      common /sc3/beamc, scdist, sce10, cplm, ect, apl, ichaes, iscsp
      common /npart/imaxr
      common /part/xc(iptsz), yc(iptsz), zc(iptsz)
      common /twcst/epsilon
      common /beamsa/fs(7, iptsz)
      common /dcspa/iesp
      common /cmpte/iell
      common /champ/fxrms(10, 15), fyrms(10, 15), fzrms(10, 15), nchamp(10), nccham(10), nchpas, jcham, itye
      common /compt/nrres, nrtre, nrbunc, nrdbun
      common /posc/xpsc
      logical ichaes, iesp
      ! *************************************************
      ! nquad : number of quad in the transport line
      common /chqua/icqd, nquad
      logical icqd
      ! *************************************************
      common /dimens/zcp(iptsz), xcp(iptsz), ycp(iptsz)

      if (beamc==0. .or. scdist==0.) return
      ! dummy: in order to have the same entry as HERSC and SCHEFF
      ! Initialize some constants and variables c wavel in cm
      ect = 4.
      call shuffle
      call pintim
      iell = iell + 1
      imaxf = ngood
      wavel = 2.*pi*vl/fh
      xmass = xmat*1.78267581e-30
      nmaz = 14
      nmazr = 8
      nmaxy = 4
      dxp = 0.
      dyp = 0.
      dw = 0.
      dz = scdist/100.
      dz1 = dz
      zsot1 = 0.
      if (ngood==0) then
        write (16, *) ' all the particles are lost '
        stop
      end if
      write (16, *) ' call SCHERM N: ', iell
      ! xi in Amps, beamc in mA
      ! epsilon =(coul*coul)/nt*(m*m)
      epsilon = 8.854189586e-12
      c1 = 1./(3.*pi*sqrt(5.))
      cl = vl/100.
      ! charge per macro particle
      const3 = 1.e-06
      const2 = 1.e-06/xmat
      ! normalized emittances(normalized) in m.radian
      ! calculate rms beam size for beam in one point in time
      call sizrms(0, xrms, yrms, zrms, zz)
      xrmsp = xrms
      yrmsp = yrms
      zrmsp = zrms
      call sizcor(ect, xrms, yrms, zrms, 0)
      write (16, *) ' bunch RMS(m): ', xrms, yrms, zrms
      ! 6875   format(2x,e12.5,2x,e12.5,2x,e12.5)
      xrmsc = xrms
      yrmsc = yrms
      zrmsc = zrms
      xrms = xrmsp
      yrms = yrmsp
      zrms = zrmsp
      ! Total bunch charge densities in x,y,z
      ! calculation of Hermite coefficients
      do i = 1, ngood
        zcp(i) = zc(i)
        xcp(i) = xc(i)
        ycp(i) = yc(i)
      end do
      ! limits in z-direction
      zmat = 0.
      zmit = 1000.
      do i = 1, ngood
        if (zcp(i)>=zmat) zmat = zcp(i)
        if (zcp(i)<zmit) zmit = zcp(i)
      end do
      zmat = zmat/zrms
      zmit = zmit/zrms
      ! extend zmat
      zmat = zmat + zmat*.50
      zmit = zmit + zmit*.50
      ! (xmat,ymat,zmat) >0
      if (zmat>ect) zmat = ect
      if (abs(zmit)>ect) zmat = -ect
      ! Hermite coefficients
      do k = 1, nmaxy
        afxt(k) = 0.
        afyt(k) = 0.
        kap = k - 1
        do j = 1, ngood
          xcoup = abs(xcp(j)/xrms)
          ycoup = abs(ycp(j)/yrms)
          zcoup = abs(zcp(j)/zrms)
          if (xcoup<=ect .and. ycoup<=ect .and. zcoup<=ect) then
            xc(j) = xcp(j)/xrmsc
            yc(j) = ycp(j)/yrmsc
            afxt(k) = afxt(k) + herm(2*kap, xc(j))
            afyt(k) = afyt(k) + herm(2*kap, yc(j))
          end if
        end do
        afxt(k) = afxt(k)/(fact(2*kap)*sqrt(2.*pi))
        afyt(k) = afyt(k)/(fact(2*kap)*sqrt(2.*pi))
      end do
      ! 6876   format(2x,i5,3x,e12.5,3x,e12.5)
      do k = 1, nmaz
        afzt(k) = 0.
        kap = k - 1
        do j = 1, ngood
          xcoup = abs(xcp(j)/xrms)
          ycoup = abs(ycp(j)/yrms)
          zcoup = abs(zcp(j)/zrms)
          if (xcoup<=ect .and. ycoup<=ect .and. zcoup<=ect) then
            zc(j) = zcp(j)/zrms
            afzt(k) = afzt(k) + herm(kap, zc(j))
          end if
        end do
        afzt(k) = afzt(k)/(fact(kap)*sqrt(2.*pi))
      end do
      ! 6877   format(3x,e12.5)
      ! Seek for surface of the bunch
      szbt = snzt(zmit, zmat)
      ! Seek for the vertex of the distribution n(z)
      ! between  0 and zmat/2
      zf = zmat/2.
      zi = 0.
      call rchsom(zi, zf, nmaz)
      zsot = (zi+zf)/2.
      ! 9999   CONTINUE
      zcgd = zsot*zrms
      ! Main ellipsoid (in the right of the vertex)
      imaxd = 1
      do i = 1, ngood
        if (zcp(i)>=zcgd) then
          xc(imaxd) = xcp(i)
          yc(imaxd) = ycp(i)
          zc(imaxd) = zcp(i)
          imaxd = imaxd + 1
        end if
      end do
      imaxd = imaxd - 1
      imaxr = ngood - 2*imaxd
      if (imaxr<0) then
        ! if imaxr<0 => use one ellips only, rather than 2
        pcent1 = float(2*imaxd)/float(ngood)
        pcent2 = float(imaxr)/float(ngood)
        if (icqd) nquad = nquad - 1
        iell = iell - 1
        write (16, *) ' one ellipsoid in z-direction '
        call pintim
        call schermi1
        return
      end if
      if (25*imaxr<imaxf .or. imaxr<=30) then
        pcent1 = float(2*imaxd)/float(ngood)
        pcent2 = float(imaxr)/float(ngood)
        iell = iell - 1
        if (icqd) nquad = nquad - 1
        ! if imaxr<.04*imaxf => use one ellips only, rather than 2
        write (16, *) 'one ellipsoid in z-direction '
        call pintim
        call schermi1
        if (12*imaxr<ngood) write (16, *) 'one ellipsoid in z-direction '
        if (imaxr<=40) write (16, *) ' one ellipsoid in z-direction '
        return
      end if
      i1elli = 0
      ! C.O.G. of the principal ellipsoid (in cm)
      ! longitudinal RMS of the pricipal ellipsoid
      zrmss1 = sqrt(vaprz(zsot,zmat))
      zrms1 = zrmss1*zrms
      ! RMS in the transverse directions
      xrms1 = xrms
      yrms1 = yrms
      ! surface n(z)
      szbd = snzd(zsot, zmat)
      rsnz = szbd/szbt
      ! coefficients Hermite en x,y,z sur partie droite en z
      ! principal ellipsoid
      do k = 1, nmaxy
        kap = k - 1
        afxm(k) = afxt(k)*rsnz
        afym(k) = afyt(k)*rsnz
        afzm(k) = prinz(zsot, zmat, k, zrmss1)
        afzm(k) = 2.*afzm(k)/(fact(2*kap)*sqrt(2.*pi))
      end do
      ! limits in x,y,z of the principal ellipsoid
      do i = 1, imaxd
        xc(i) = xc(i)/xrms
        yc(i) = yc(i)/yrms
        zc(i) = zc(i)/zrms
      end do
      xmam = xc(1)
      ymam = yc(1)
      zmam = zc(1)
      do i = 1, imaxd
        if (xc(i)>=xmam) xmam = xc(i)
        if (yc(i)>=ymam) ymam = yc(i)
        if (zc(i)>=zmam) zmam = zc(i)
      end do
      if (abs(xmam)>=ect) xmam = ect
      if (abs(ymam)>=ect) ymam = ect
      if (abs(zmam)>=ect) zmam = ect
      xmim = xmam
      ymim = ymam
      zmim = zmam
      do i = 1, imaxd
        if (xc(i)<xmim) xmim = xc(i)
        if (yc(i)<ymim) ymim = yc(i)
        if (zc(i)<zmim) zmim = zc(i)
      end do
      if (abs(xmim)>=ect) xmim = -ect
      if (abs(ymim)>=ect) ymim = -ect
      if (abs(zmim)>=ect) zmim = -ect
      ! partition commune @ x,y,z
      xymam = ymam
      xymim = ymim
      if (xmam>=xymam) xymam = xmam
      if (zmam>=xymam) xymam = zmam
      if (xmim<xymim) xymim = xmim
      if (zmim<xymim) xymim = zmim
      ! symmetrisation de l'intervalle
      if (abs(xymim)>=xymam) then
        xymam = abs(xymim)
      else
        xymim = -xymam
      end if
      ! vertex of the second ellipsoid
      aa = zmit
      bb = 2.*zsot - zmat
      cc = zsot
      dd = zmat
      call rchsor(aa, bb, cc, dd, ee)
      ! second ellipsoid  around ee
      ! sz2e : surface
      zrms2 = varia(bb, cc, dd, ee)
      zrms2 = sqrt(zrms2)
      zcgr = ee*zrms
      sz2e = codsy(bb, cc, dd, ee, 1)
      afzr(1) = sz2e/sqrt(2.*pi)
      stm12 = abs(afzt(1)-afzm(1)-afzr(1))
      rs2e = sz2e/szbt
      xrms2 = xrms
      yrms2 = yrms
      do k = 1, nmaxy
        kap = k - 1
        afxr(k) = afxt(k)*rs2e
        afyr(k) = afyt(k)*rs2e
        afzr(k) = codsy(bb, cc, dd, ee, k)
        afzr(k) = afzr(k)/(fact(2*kap)*sqrt(2.*pi))
      end do
      ! two ellipsoids:
      if (stm12*10<=afzr(1)) inint = 2
      if (stm12*10>afzr(1)) then
        ! 3 ellipsoids;the principal ellipsoid,the second ellipsoid is symmetrized
        ! the third ellipsoid is defined around the c. of g. of the residu
        ee1 = grz(aa, bb, cc, dd, ee)
        if (ee1>ee) then
          inint = 2
          go to 1968
        end if
        zrms3 = variz(bb, cc, dd, ee, ee1)
        zrms3 = sqrt(zrms3)
        xrms3 = xrms
        yrms3 = yrms
        zcgr3 = ee1*zrms
        ! C.O.G. of the second ellipsoid
        ! on suppose xcgr et ycgr nuls pour le residu
        xcgr = 0.
        ycgr = 0.
        sz3e = codif(bb, cc, dd, ee, ee1, 1)
        rs3e = sz3e/szbt
        ! correction complementaire
        srtot = sz3e/sqrt(2.*pi) + afzr(1) + afzm(1)
        srtot = srtot - afzt(1)
        ! HErMITE coefficients over the residual  ellips
        do k = 1, nmaxy
          kap = k - 1
          afxrr(k) = afxt(k)*rs3e
          afyrr(k) = afyt(k)*rs3e
          afzrr(k) = codif(bb, cc, dd, ee, ee1, k)
          afzrr(k) = afzrr(k)/(fact(2*kap)*sqrt(2.*pi))
          if (k==1) then
            tzrr = afzrr(k) - srtot
            if (tzrr>=0. .and. abs(tzrr)>=(afzrr(k)/10.)) then
              afxrr(k) = afxrr(k) - srtot
              afyrr(k) = afyrr(k) - srtot
              afzrr(k) = afzrr(k) - srtot
            end if
          end if
        end do
        ! end of calculus of 2nd ellips
        inint = 3
      end if
      zrms3 = zrms3*zrms
1968  continue
      zrms2 = zrms2*zrms
      ! surface of the ellipsoids in pourcent
      write (16, *) ' surface of the ellipsoids in % of the bunch:'
      if (inint==2) then
        pcent1 = afzm(1)/afzt(1)
        pcent2 = afzr(1)/afzt(1)
        write (16, 7777) iell, pcent1, pcent2
      end if
      if (inint==3) then
        pcent1 = afzm(1)/afzt(1)
        pcent2 = afzr(1)/afzt(1)
        pcent3 = afzrr(1)/afzt(1)
        write (16, 7778) iell, pcent1, pcent2, pcent3
      end if
7777  format (2x, i4, 2x, f7.4, 2x, f7.4)
7778  format (2x, i4, 2x, f7.4, 2x, f7.4, 2x, f7.4)
      ! Do Hermite integration to determine Ex,Ey,Ez for each macro particle
      ! and apply space charge kick. Field components are passed through the
      ! common INTGRT in units Newton/Coulomb
      ! gsct introduit pour calcul specifique impulsion
      gsct = 0.
      igsct = 0
      do i = 1, ngood
        ! reprise coordonnees spaciales pour calcul des champs
        xc(i) = xcp(i)
        yc(i) = ycp(i)
        zc(i) = zcp(i)
        ! principal ellipsoid
        call intga(i, 0)
        ext = ex
        eyt = ey
        ezt = ez
        ! second ellipsoid
        call intga(i, 1)
        ext = ext + ex
        eyt = eyt + ey
        ezt = ezt + ez
        ! third ellipsoid
        if (inint==3) then
          call intga(i, 2)
          ext = ext + ex
          eyt = eyt + ey
          ezt = ezt + ez
        end if
        ! calculate kick in x',y' and z' (energy)
        ! isochronism correction
        eztp = ezt*cos(apl) - ext*sin(apl)
        extp = ezt*sin(apl) + ext*cos(apl)
        ezt = eztp
        ext = extp
        gsc = f(7, i)/xmat
        gsct = gsct + gsc
        igsct = igsct + 1
        bsc = sqrt(1.-1./(gsc*gsc))
        dxp = const2*ext*dz/(bsc*bsc*gsc*gsc*gsc)*abs(f(9,i))
        dyp = const2*eyt*dz/(bsc*bsc*gsc*gsc*gsc)*abs(f(9,i))
        dw = const3*ezt*dz/gsc
        if (.not. iesp) then
          ! load the entrance beam parameters for cavities or gaps
          do js = 1, 7
            f(js, i) = fs(js, i)
          end do
          f(3, i) = f(3, i) + dxp*1000.
          f(5, i) = f(5, i) + dyp*1000.
          f(2, i) = f(2, i) - dz1*dxp*100.*xpsc
          f(4, i) = f(4, i) - dz1*dyp*100.*xpsc
          ! omment           f(2,i)=f(2,i)-dz1*dxp*100.
          ! omment           f(4,i)=f(4,i)-dz1*dyp*100.
          dwp(i) = dw
        else
          f(3, i) = f(3, i) + dxp*1000.
          f(5, i) = f(5, i) + dyp*1000.
          f(7, i) = f(7, i) + dw
        end if
      end do
      return
    end subroutine schermi
    ! *******************************************************************
    ! SUBROUTINE entre
    ! define some input beam characteristics
    ! uem : Rest mass in MeV

    ! proton:938.27231  MeV
    ! H_    :939.3145   MeV
    ! mesons:33.9093    MeV
    ! pions :139.5685   MeV
    ! kaons :493.667    MeV
    ! electrons : 0.511 MeV

    ! atm : Atomic number
    ! qst : charge

    ! enedep: Kinetic energy
    ! tofini: Time of flight

    ! REMARK : After INPUT the reference coincides with the c.o.g.
    ! *******************************************************************
    subroutine entre
      implicit real *8(a-h, o-z)
      parameter(iptsz=100002, maxcell=3000, maxcell1=3000)
      common /consta/vl, pi, xmat, rpel, qst
      common /speda/dave, idave
      common /ttfc/tk, t1k, t2k, sk, s1k, s2k, fh
      common /dyn/tref, vref
      common /dyni/vrefi, trefi, fhinit, acpt
      common /faisc/f(10, iptsz), imax, ngood
      common /objet/fo(9, iptsz), imaxo
      common /histo/centre(6)
      common /qmoyen/qmoy
      common /rigid/boro
      common /mastrp/xma(2, 2), xmb(2, 2), xmc(2, 2)
      common /stis/suryth, surzph, enedep, ecogde, testca
      common /etcom/cog(8), exten(17), fd(iptsz)
      common /tapes/in, ifile, meta
      common /davcom/dav1(maxcell1, 40), davtot, iitem(maxcell1), idav
      common /tilt/tipha, tix, tiy, shifw, shifp
      common /newtlt/twissa(3), itwiss
      common /tof/tofini
      common /strip/atm, qs, atms, ths, qop, sqst(6), anp, nqst
      common /mcs/imcs, ncstat, cstat(20)
      common /trace3d/trace3h(100), trace3t(maxcell1), tif, kt3h, kt3t, fid
      common /trace3e/tracebi(6), traceei(3)
      character *128 trace3h, trace3t, tif
      logical dave
      ! dimension foo(9)
      dave = .false.
      read (in, *) uem, atm, qst
      if (ncstat==1) cstat(1) = qst
      ! input energy(MeV) and initial time of flight(deg)
      read (in, *) enedep, tofini
      ! if icog=0 reference (vref,tref) is not cog
      ! if icog=1 reference (vref,tref) is cog
      ! --- xmat= rest mass
      xmat = uem*atm
      write (16, 101) uem, atm, xmat, qst
101   format ('  **** unit mass: ', e12.5, ' MeV mass units: ', f5.1, ' rest mass: ', e12.5, ' MeV charge ', f4.1)
      write (16, 102) enedep, tofini
102   format ('  **** energy: ', e12.5, ' MeV initial tof: ', e12.5, ' deg')
      tofini = tofini*pi/(180.*fh)
      gdep = enedep/xmat + 1.
      bdep = sqrt(1.-1./(gdep*gdep))

      tracebi(6) = tracebi(6)*sqrt(atm)
      write (tif, 901)(tracebi(i), i=1, 6)
901   format (' BEAMI(1)= ', 5(f12.6,1x), f12.4)
      kt3h = kt3h + 1
      trace3h(kt3h) = tif
      traceei(3) = traceei(3)/sqrt(atm)
      write (tif, 902)(traceei(i), i=1, 3)
902   format (' EMITI(1)= ', f12.6, 1x, f12.6, 1x, f12.4)
      kt3h = kt3h + 1
      trace3h(kt3h) = tif

      write (tif, 903) uem*atm/qst, fhinit/2./pi/1.e6
903   format (' ER= ', e16.7, ', Q=1 FREQ= ', e14.7)
      kt3h = kt3h + 1
      trace3h(kt3h) = tif
      write (tif, 7001) enedep/qst
7001  format (' W= ', f12.4)
      kt3h = kt3h + 1
      trace3h(kt3h) = tif
      ! fo(index,i), index=1 initial particle # ,
      ! index=2 x
      ! index=3 xp
      ! index=4 y
      ! index=5 yp
      ! index=6 time of flight (tof)
      ! index=7 energy
      ! index=8 if = 0 , then particle is lost
      ! index=9 charge
      ! i= particle #
      do i = 1, ngood
        ! if itwiss=1,  apply tofini in tiltbm routine
        if (itwiss/=1) fo(6, i) = fo(6, i) + tofini
        fo(9, i) = qst
        fo(7, i) = enedep + fo(1, i) + xmat
        if (fo(7,i)<xmat) fo(7, i) = xmat
        fo(1, i) = float(i)
      end do
      ! --- the reference particle and the cog coincide
      bref = 0.
      tref = 0.
      encog = 0.
      do i = 1, ngood
        encog = encog + fo(7, i)
        gai = fo(7, i)/xmat
        bref = bref + sqrt(1.-1/(gai*gai))
        tref = tref + fo(6, i)
      end do
      encog = encog/float(ngood)
      bref = bref/float(ngood)
      vref = bref*vl
      tref = tref/float(ngood)
      vrefi = vref
      trefi = tref
      ! pack the table f(,) of the current beam
      do i = 1, ngood
        do j = 1, 9
          f(j, i) = fo(j, i)
        end do
      end do
      ! momentum of the  reference (i.e. the c.o.g.)
      gcog = 1./sqrt(1.-bref*bref)
      boro = 3.3356*xmat*bref*gcog/abs(qst)
      write (16, 3450) boro
3450  format ('  **** momentum of c.o.g. (kG.cm): ', e12.5)
      if (itwiss==1) then
        ! Beam was defined in MCOBJET with Twiss parameters
        ! call TILTBM to apply Twiss alpha
        tipha = twissa(3)
        tix = twissa(1)
        tiy = twissa(2)
        shifw = .000000
        shifp = .000000
        icg = 1
        call tiltbm(icg)
        ! write the input beam in file 'input.beam'
        dum = 0.
        write (11, *) ngood, dum, fh/(2000000.*pi)
        do i = 1, ngood
          f(2, i) = f(2, i) + centre(2)
          f(3, i) = f(3, i) + centre(3)
          f(4, i) = f(4, i) + centre(4)
          f(5, i) = f(5, i) + centre(5)
          f(6, i) = f(6, i) + centre(6)
          f(7, i) = f(7, i) + centre(1)
          etphas = fh*(f(6,i)-tref)
          etener = f(7, i) - xmat
          write (11, 777) f(2, i), f(3, i)/1000., f(4, i), f(5, i)/1000., etphas, etener
        end do
777     format (6(f13.8,1x))
      else
        ! in case of itwiss.ne.1 apply CENTRE and write input beam in TILTBM
        tipha = 0.
        tix = 0.
        tiy = 0.
        shifw = .000000
        shifp = .000000
        icg = 1
        call tiltbm(icg)
      end if
      call emiprt(0)
      return
    end subroutine entre
    ! *******************************************************************
    ! SUBROUTINE monte
    ! random generation of the 6D coordinates of the cloud of particles
    ! LOI : 1 IMAX particles are generated randomly in three phase
    ! plane ellipse with uniform distribution in real space
    ! (x,y,z), then xp,yp, and zp from within each phase-plane
    ! ellipse. z,zp are converted to phi,w
    ! LOI : 2 IMAX particles are generated randomly in a six
    ! dimensional ellipsoid
    ! LOI : 3 IMAX particles are generated randomly in three phase
    ! plane ellipse in real space (x,y,z),with distribution
    ! corrresponding to an equilibrium stationary sphere at the
    ! limit of the of the current acceptable (see help_DYNAC).
    ! Then xp,yp, and zp from within each phase-plane for
    ! each phase-plane ellipse. z,zp are converted to phi,w
    ! LOI : 4 IMAX particles are generated randomly in a six
    ! dimensional ellipsoid from a distribution corresponding
    ! to an equilibrium stationary sphere
    ! LOI : 5 IMAX particles are generated randomly in a six
    ! dimensional cylinder (axis in z-direction)
    ! with uniform distribution in transverse directions
    ! LOI : 6 IMAX particles are generated randomly in a six
    ! dimensional cylinder (axis in z-direction)
    ! with gaussian distribution in transverse directions
    ! ITWISS=1   read Twiss parameters for emittance definition
    ! ITWISS<>1  reading emittance bounderies for upright ellips

    ! This routine uses the CERN random # routine RLUX (named ranlux in
    ! the CERN library)
    ! *******************************************************************
    subroutine monte
      implicit real *8(a-h, o-z)
      parameter(iptsz=100002, maxcell=3000, maxcell1=3000)
      common /dcspa/iesp
      common /ttfc/tk, t1k, t2k, sk, s1k, s2k, fh
      common /com4/cord(iptsz, 6)
      common /faisc/f(10, iptsz), imax, ngood
      common /objet/fo(9, iptsz), imaxo
      common /qmoyen/qmoy
      common /histo/centre(6)
      common /consta/vl, pi, xmat, rpel, qst
      common /tapes/in, ifile, meta
      common /ranec1/dummy(6)
      common /etcha1/dav2(maxcell1, 33), ichas(iptsz), chasit
      common /sc3/beamc, scdist, sce10, cplm, ect, apl, ichaes, iscsp
      common /newtlt/twissa(3), itwiss
      common /dyni/vrefi, trefi, fhinit, acpt
      common /speda/dave, idave
      common /ragau/ntir
      ! ********************************************
      ! v28/04/2015
      common /fcont/ifcont
      logical ifcont
      common /trace3d/trace3h(100), trace3t(maxcell1), tif, kt3h, kt3t, fid
      common /trace3e/tracebi(6), traceei(3)
      character *128 trace3h, trace3t, tif
      logical iesp, chasit, dave
      ! dimension fn(9,iptsz),foo(9),so(6),vecx(1)
      dimension vecx(1)

      read (in, *) loi, itwiss
      write (16, *) ' Generate particles based on law ', loi
      if (loi>6) then
        write (16, *) .gt.' ERROR in GEBEAM: law  6 invalid ! '
        stop
      end if
      read (in, *) fh, imax
      write (16, 102) fh
102   format (//, 30x, ' FREQUENCY : ', e12.5, ' Hz', //)
      fh = fh*2.*pi
      fhinit = fh
      ! Center of the beam ellipsoid
      ! X X' Y Y' Z' Z
      read (in, *)(centre(j), j=2, 5), centre(1), centre(6)
      if (itwiss/=1) then
        read (in, *) ymax, tmax, zmax, pmax, dmax, ttmax
        kt3h = kt3h + 1
        trace3h(kt3h) = .NE.'ERROR: GEBEAM ITWISS1 not yet implemented'
      else
        read (in, *) alphax, betax, emitx
        read (in, *) alphay, betay, emity
        read (in, *) alphaz, betaz, emitz
        gammax = (1.+alphax*alphax)/betax
        gammay = (1.+alphay*alphay)/betay
        ymax = 0.1*sqrt(emitx/gammax)
        tmax = sqrt(emitx*gammax)
        zmax = 0.1*sqrt(emity/gammay)
        pmax = sqrt(emity*gammay)
        twissa(1) = -alphax*ymax
        twissa(2) = -alphay*zmax
        if (loi/=5) then
          gammaz = (1.+alphaz*alphaz)/betaz
          dmax = 0.001*sqrt(emitz*gammaz)
          ttmax = pi*sqrt(emitz/gammaz)/(fh*180.)
          twissa(3) = alphaz*sqrt(emitz/gammaz)
        end if
        if (loi>=5) then
          dmax = alphaz
          twissa(3) = 0.
          ttmax = pi/fh
        end if
        if (loi==6) then
          sig = betaz
        end if
        ! store parameters for trace3d, write them in ENTRE
        tracebi(1) = alphax
        tracebi(2) = betax
        tracebi(3) = alphay
        tracebi(4) = betay
        tracebi(5) = alphaz
        tracebi(6) = betaz
        traceei(1) = emitx
        traceei(2) = emity
        traceei(3) = emitz
      end if
      ! --- beam centre is activated in SUBROUTINE entre
      cph = centre(6)*fh*180/pi
      write (16, 123)(centre(j), j=2, 5), centre(1), centre(6), cph
123   format (' *** Beam centre defined as:', /, 3x, 4x, ' Transverse direction :', /, 6x, ' HORZ PLANE X(CM) = ', &
        e12.5, '       XP(MRD) = ', e12.5, /, 6x, ' VERT PLANE Y(CM) = ', e12.5, '       YP(MRD) = ', e12.5, /, 4x, &
        ' LONGITUDINAL :', /, 5x, ' DELTA ENERGY(MeV) = ', e12.5, '     TIME(SEC) = ', e12.5, /, 41x, ' PHASE(DEG) = ', &
        e12.5, //)
      ptmax = ttmax*fh*180./pi
      if (itwiss/=1) then
        write (16, 99) ymax, tmax, zmax, pmax, dmax, ttmax, ptmax
99      format (3x, ' *** Limits of the random distribution ', /, 4x, ' Transverse direction :', /, 6x, &
          ' HORZ PLANE X(CM) = ', e12.5, '       XP(MRD) = ', e12.5, /, 6x, ' VERT PLANE Y(CM) = ', e12.5, &
          '       YP(MRD) = ', e12.5, /, 4x, ' LONGITUDINAL :', /, 5x, ' DELTA ENERGY(MeV) = ', e12.5, &
          '     TIME(SEC) = ', e12.5, /, 41x, ' PHASE(DEG) = ', e12.5, //)
      else
        ! if(loi.eq.5) then
        if (loi>=5) then
          write (16, *) ' Beam distribution based on Twiss parameters'
          write (16, 199) alphax, betax, emitx, alphay, betay, emity
          write (16, 399) ptmax, dmax
399       format (4x, ' Continuous beam in the longitudinal direction :', /, 6x, ' half phase length (deg): ', e12.5, /, &
            6x, ' half energy width (MeV): ', e12.5)
          ! continuous beam
          ifcont = .true.
        else
          write (16, *) ' Beam distribution based on Twiss parameters'
          write (16, 199) alphax, betax, emitx, alphay, betay, emity
199       format (4x, ' Transverse direction :', /, 6x, ' Horz plane: alpha: ', e12.5, ' beta(mm/mrad): ', e12.5, &
            ' emit(pi*mm*mrad): ', e12.5, /, 6x, ' Vert plane: alpha: ', e12.5, ' beta(mm/mrad): ', e12.5, &
            ' emit(pi*mm*mrad): ', e12.5)
          write (16, 299) alphaz, betaz, emitz
299       format (4x, ' Longitudinal direction :', /, 6x, ' alpha: ', e12.5, ' beta(deg/keV): ', e12.5, &
            ' emit(pi*deg*keV): ', e12.5)
        end if
      end if
      ! len : starting value of the random vector for the routine rlux
      len = 1
      do j = 1, 6
        cord(1, j) = 0.0
      end do
      if (loi==1) then
        do i = 2, imax
150       continue
          call rlux(vecx, len)
          r1 = 2.*vecx(1) - 1.
          call rlux(vecx, len)
          r3 = 2.*vecx(1) - 1.
          call rlux(vecx, len)
          r6 = 2.*vecx(1) - 1.
          ! make round in x,y,z plane
          rho = r1**2 + r3**2 + r6**2
          if (rho>1) go to 150
152       call rlux(vecx, len)
          r2 = 2.*vecx(1) - 1.
          ! make beam round in x,x' plane
          if ((r1*r1+r2*r2)>1.) go to 152
153       call rlux(vecx, len)
          r4 = 2.*vecx(1) - 1.
          ! make beam round in y,yp plane
          if ((r4*r4+r3*r3)>1.) go to 153
180       call rlux(vecx, len)
          r5 = 2.*vecx(1) - 1.
          ! make beam round in plane z, zp
          if ((r6*r6+r5*r5)>1.) go to 180
          ! store random numbers in preparation for rms correction
          cord(i, 1) = r1
          cord(i, 2) = r2
          cord(i, 3) = r3
          cord(i, 4) = r4
          cord(i, 5) = r5
          cord(i, 6) = r6
        end do
      end if
      if (loi==2) then
        do i = 2, imax
1500      call rlux(vecx, len)
          r1 = 2.*vecx(1) - 1.
          call rlux(vecx, len)
          r2 = 2.*vecx(1) - 1.
          ! make round x,xp
          rho = r1*r1 + r2*r2
          if (rho>1) go to 1500
1530      call rlux(vecx, len)
          r3 = 2.*vecx(1) - 1.
          call rlux(vecx, len)
          r4 = 2.*vecx(1) - 1.
          ! make beam round in y,yp plane
          if ((r4*r4+r3*r3)>1.) go to 1530
1800      call rlux(vecx, len)
          r5 = 2.*vecx(1) - 1.
          call rlux(vecx, len)
          r6 = 2.*vecx(1) - 1.
          ! make beam round in plane z, zp
          if ((r6*r6+r5*r5)>1.) go to 1800
          ! make round x,xp,y,yp,z,zp
          rho = r1**2 + r2**2 + r3**2 + r4**2 + r5**2 + r6**2
          if (rho>1.0) go to 1500
          ! store random numbers in preparation for rms correction
          cord(i, 1) = r1
          cord(i, 2) = r2
          cord(i, 3) = r3
          cord(i, 4) = r4
          cord(i, 5) = r5
          cord(i, 6) = r6
        end do
      end if
      if (loi==3) then
        ntir = 24
        s = .2493
        am = 0.
        do i = 2, imax
14        call gcern(len, s, am, vec)
          r1 = vec
          call gcern(len, s, am, vec)
          r3 = vec
          call gcern(len, s, am, vec)
          r6 = vec
          ! make round in x,y,z plane
          rho = r1**2 + r3**2 + r6**2
          if (rho>1) go to 14
16        call gcern(len, s, am, vec)
          r2 = vec
          ! make beam round in x,x' plane
          if ((r1*r1+r2*r2)>1.) go to 16
17        call gcern(len, s, am, vec)
          r4 = vec
          ! make beam round in y,yp plane
          if ((r4*r4+r3*r3)>1.) go to 17
22        call gcern(len, s, am, vec)
          r5 = vec
          ! make beam round in plane z, zp
          if ((r6*r6+r5*r5)>1.) go to 22
          ! store random numbers in preparation for rms correction
          cord(i, 1) = r1
          cord(i, 2) = r2
          cord(i, 3) = r3
          cord(i, 4) = r4
          cord(i, 5) = r5
          cord(i, 6) = r6
        end do
      end if
      if (loi==4) then
        ntir = 12
        s = .2493
        am = 0.
        do i = 2, imax
101       call gcern(len, s, am, vec)
          r1 = vec
          call gcern(len, s, am, vec)
          r2 = vec
          ! make beam round in x,xp plane
          rho = r1*r1 + r2*r2
          if (rho>1) go to 101
112       call gcern(len, s, am, vec)
          r3 = vec
          call gcern(len, s, am, vec)
          r4 = vec
          ! make beam round in y,yp plane
          if ((r3*r3+r4*r4)>1.) go to 112
113       call gcern(len, s, am, vec)
          r5 = vec
          call gcern(len, s, am, vec)
          r6 = vec
          ! make beam round in plane z, zp
          if ((r6*r6+r5*r5)>1.) go to 113
          ! store random numbers in preparation for rms correction
          ! make round x,xp,y,yp,z,zp
          rho = r1**2 + r2**2 + r3**2 + r4**2 + r5**2 + r6**2
          if (rho>1.0) go to 101
          cord(i, 1) = r1
          cord(i, 2) = r2
          cord(i, 3) = r3
          cord(i, 4) = r4
          cord(i, 5) = r5
          cord(i, 6) = r6
        end do
      end if
      if (loi==5) then
        do i = 2, imax
1566      continue
          call rlux(vecx, len)
          r1 = 2.*vecx(1) - 1.
          call rlux(vecx, len)
          r3 = 2.*vecx(1) - 1.
          ! make round in x,y plane
          rho = r1**2 + r3**2
          if (rho>1) go to 1566
1525      call rlux(vecx, len)
          r2 = 2.*vecx(1) - 1.
          ! make beam round in x,x' plane
          if ((r1*r1+r2*r2)>1.) go to 1525
1535      call rlux(vecx, len)
          r4 = 2.*vecx(1) - 1.
          ! make beam round in y,yp plane
          if ((r4*r4+r3*r3)>1.) go to 1535
          ! make round x,xp,y,yp
          rho = r1**2 + r2**2 + r3**2 + r4**2
          if (rho>1.0) go to 1566
          ! *et*2010-11-23  do NOT make beam round in z,zp plane
          ! et1835       call rlux(vecx,len)
          call rlux(vecx, len)
          r5 = 2.*vecx(1) - 1.
          call rlux(vecx, len)
          r6 = 2.*vecx(1) - 1.
          ! et           if((r6*r6+r5*r5).gt.1.) go to 1835
          ! store random numbers in preparation for rms correction
          cord(i, 1) = r1
          cord(i, 2) = r2
          cord(i, 3) = r3
          cord(i, 4) = r4
          cord(i, 5) = r5
          cord(i, 6) = r6
        end do
      end if
      if (loi==6) then
        ! Gaussian
        do i = 2, imax
          call rgaus2(sig, y1, y2, y3, y4)
          ! do NOT make beam gaussian in z,zp plane
          call rlux(vecx, len)
          r5 = 2.*vecx(1) - 1.
          call rlux(vecx, len)
          r6 = 2.*vecx(1) - 1.

          ! store random numbers in preparation for rms correction
          cord(i, 1) = y1
          cord(i, 2) = y2
          cord(i, 3) = y3
          cord(i, 4) = y4
          cord(i, 5) = r5
          cord(i, 6) = r6
        end do
        y1x = abs(cord(2,1))
        y2x = abs(cord(2,2))
        y3x = abs(cord(2,3))
        y4x = abs(cord(2,4))
        do i = 3, imax
          if (abs(cord(i,1))>y1x) y1x = abs(cord(i,1))
          if (abs(cord(i,2))>y2x) y2x = abs(cord(i,2))
          if (abs(cord(i,3))>y3x) y3x = abs(cord(i,3))
          if (abs(cord(i,4))>y4x) y4x = abs(cord(i,4))
        end do
        do i = 2, imax
          cord(i, 1) = cord(i, 1)/y1x
          cord(i, 2) = cord(i, 2)/y2x
          cord(i, 3) = cord(i, 3)/y3x
          cord(i, 4) = cord(i, 4)/y4x
        end do
      end if
      call corre(imax, imax)
      ! fimax=ttmax*fh*180./pi
      ! maximum extent in case of continous beam is +/-pi (i.e. +/-180 deg)
      tcorct = abs(.5*cord(2,6)*ttmax)
      ! in fo(1,) is stored the energy extent (MeV)
      do i = 2, imax
        fo(1, i) = .5*cord(i, 5)*dmax
        fo(2, i) = .5*cord(i, 1)*ymax
        fo(3, i) = .5*cord(i, 2)*tmax
        fo(4, i) = .5*cord(i, 3)*zmax
        fo(5, i) = .5*cord(i, 4)*pmax
        fo(6, i) = .5*cord(i, 6)*ttmax
        if (abs(fo(6,i))>tcorct) tcorct = abs(fo(6,i))
      end do
      ! first particle
      ! ccc        imax=imax+1
      ichas(1) = 1
      fo(8, 1) = 1.
      do j = 1, 6
        fo(j, 1) = 0.
      end do
      ! if(loi.ne.5) then
      if (loi<5) then
        do i = 2, imax
          fo(8, i) = 1
          ichas(i) = 1
        end do
      else
        ! correct the phase length for a continuous beam (force +/- 180 deg)
        tcorct = ttmax/tcorct
        do i = 2, imax
          fo(8, i) = 1
          ichas(i) = 1
          fo(6, i) = fo(6, i)*tcorct
        end do
      end if
      ngood = imax
      imaxo = imax
      write (16, 8) loi, imax
8     format (8x, '  ****law ', i2, '  with ', i6, ' particles', /)
      return
    end subroutine monte
    ! *******************************************************************
    ! subroutine rgaus2(sigma,y1,y2,y3,y4)
    ! called by subroutine MONTE
    ! *******************************************************************
    subroutine rgaus2(sigma, y1, y2, y3, y4)
      implicit real *8(a-h, o-z)
      dimension vecx(1)

      len = 1
      do while ((w1>=1.0) .or. (w1==0.))
        call rlux(vecx, len)
        x1 = 2.0*vecx(1) - 1.0
        call rlux(vecx, len)
        x3 = 2.0*vecx(1) - 1.0
        w1 = x1*x1 + x3*x3
      end do
      do while ((w2>=1.0) .or. (w2==0.))
        call rlux(vecx, len)
        x2 = 2.0*vecx(1) - 1.0
        call rlux(vecx, len)
        x4 = 2.0*vecx(1) - 1.0
        w2 = x2*x2 + x4*x4
      end do
      w1 = sigma*sqrt((-2.0*log(w1))/w1)
      w2 = sigma*sqrt((-2.0*log(w2))/w2)
      y1 = x1*w1
      y2 = x2*w2
      y3 = x3*w1
      y4 = x4*w2
      return
    end subroutine rgaus2
    ! *******************************************************************
    ! SUBROUTINE rlux(RVEC,LENV)
    ! ranlux.f Rev 1.2  1997/09/22 13:45:47  mclareni
    ! Correct error in initializing RANLUX by using RLUXIN with the
    ! output of RLUXUT from a previous run.
    ! CERN Mathlib gen

    ! Subtract-and-borrow random number generator proposed by
    ! Marsaglia and Zaman, implemented by F. James with the name
    ! RCARRY in 1991, and later improved by Martin Luescher
    ! in 1993 to produce "Luxury Pseudorandom Numbers".
    ! Fortran 77 coded by F. James, 1993

    ! LUXURY LEVELS.
    ! ------ ------      The available luxury levels are:

    ! level 0  (p=24): equivalent to the original RCARRY of Marsaglia
    ! and Zaman, very long period, but fails many tests.
    ! level 1  (p=48): considerable improvement in quality over level 0,
    ! now passes the gap test, but still fails spectral test.
    ! level 2  (p=97): passes all known tests, but theoretically still
    ! defective.
    ! level 3  (p=223): DEFAULT VALUE.  Any theoretically possible
    ! correlations have very small chance of being observed.
    ! level 4  (p=389): highest possible luxury, all 24 bits chaotic.

    ! ++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
    ! Calling sequences for RANLUX:                                  ++
    ! CALL RANLUX (RVEC, LEN)   returns a vector RVEC of LEN     ++
    ! 32-bit random floating point numbers between      ++
    ! zero (not included) and one (also not incl.).     ++
    ! CALL RLUXGO(LUX,INT,K1,K2) initializes the generator from  ++
    ! one 32-bit integer INT and sets Luxury Level LUX  ++
    ! which is integer between zero and MAXLEV, or if   ++
    ! LUX .GT. 24, it sets p=LUX directly.  K1 and K2   ++
    ! should be set to zero unless restarting at a break++
    ! point given by output of RLUXAT (see RLUXAT).     ++
    ! CALL RLUXAT(LUX,INT,K1,K2) gets the values of four integers++
    ! which can be used to restart the RANLUX generator ++
    ! at the current point by calling RLUXGO.  K1 and K2++
    ! specify how many numbers were generated since the ++
    ! initialization with LUX and INT.  The restarting  ++
    ! skips over  K1+K2*E9   numbers, so it can be long.++
    ! A more efficient but less convenient way of restarting is by: ++
    ! CALL RLUXIN(ISVEC)    restarts the generator from vector   ++
    ! ISVEC of 25 32-bit integers (see RLUXUT)      ++
    ! CALL RLUXUT(ISVEC)    outputs the current values of the 25 ++
    ! 32-bit integer seeds, to be used for restarting ++
    ! ISVEC must be dimensioned 25 in the calling program        ++
    ! *******************************************************************
    subroutine rlux(rvec, lenv)
      implicit real *8(a-h, o-z)
      dimension rvec(lenv)
      ! DIMENSION SEEDS(24), ISEEDS(24), ISDEXT(25)
      dimension seeds(24), iseeds(24)
      parameter(maxlev=4, lxdflt=3)
      dimension ndskip(0:maxlev)
      dimension next(24)
      parameter(twop12=4096., igiga=1000000000, jsdflt=314159265)
      parameter(itwo24=2**24, icons=2147483563)
      save notyet, i24, j24, carry, seeds, twom24, twom12, luxlev
      save nskip, ndskip, in24, next, kount, mkount, inseed
      integer luxlev
      logical notyet
      data notyet, luxlev, in24, kount, mkount/.true., lxdflt, 0, 0, 0/
      data i24, j24, carry/24, 10, 0./
      ! default
      ! Luxury Level   0     1     2   *3*    4
      data ndskip/0, 24, 73, 199, 365/
      ! orresponds to p=24    48    97   223   389
      ! time factor 1     2     3     6    10   on slow workstation
      ! 1    1.5    2     3     5   on fast mainframe

      ! NOTYET is .TRUE. if no initialization has been performed yet.
      ! Default Initialization by Multiplicative Congruential
      if (notyet) then
        notyet = .false.
        jseed = jsdflt
        inseed = jseed
        write (16, '(A,I12)') ' RANLUX DEFAULT INITIALIZATION: ', jseed
        luxlev = lxdflt
        nskip = ndskip(luxlev)
        lp = nskip + 24
        in24 = 0
        kount = 0
        mkount = 0
        write (16, '(A,I2,A,I4)') ' RANLUX DEFAULT LUXURY LEVEL =  ', luxlev, '      p =', lp
        twom24 = 1.
        do i = 1, 24
          twom24 = twom24*0.5
          k = jseed/53668
          jseed = 40014*(jseed-k*53668) - k*12211
          if (jseed<0) jseed = jseed + icons
          iseeds(i) = mod(jseed, itwo24)
        end do
        twom12 = twom24*4096.
        do i = 1, 24
          seeds(i) = real(iseeds(i))*twom24
          next(i) = i - 1
        end do
        next(1) = 24
        i24 = 24
        j24 = 10
        carry = 0.
        if (seeds(24)==0.) carry = twom24
      end if

      ! The Generator proper: "Subtract-with-borrow",
      ! as proposed by Marsaglia and Zaman,
      ! Florida State University, March, 1989

      do ivec = 1, lenv
        uni = seeds(j24) - seeds(i24) - carry
        if (uni<0.) then
          uni = uni + 1.0
          carry = twom24
        else
          carry = 0.
        end if
        seeds(i24) = uni
        i24 = next(i24)
        j24 = next(j24)
        rvec(ivec) = uni
        ! small numbers (with less than 12 "significant" bits) are "padded".
        if (uni<twom12) then
          rvec(ivec) = rvec(ivec) + twom24*seeds(j24)
          ! and zero is forbidden in case someone takes a logarithm
          if (rvec(ivec)==0.) rvec(ivec) = twom24*twom24
        end if
        ! Skipping to luxury.  As proposed by Martin Luscher.
        in24 = in24 + 1
        if (in24==24) then
          in24 = 0
          kount = kount + nskip
          do isk = 1, nskip
            uni = seeds(j24) - seeds(i24) - carry
            if (uni<0.) then
              uni = uni + 1.0
              carry = twom24
            else
              carry = 0.
            end if
            seeds(i24) = uni
            i24 = next(i24)
            j24 = next(j24)
          end do
        end if
      end do
      kount = kount + lenv
      if (kount>=igiga) then
        mkount = mkount + 1
        kount = kount - igiga
      end if
      return
    end subroutine rlux
    ! *******************************************************************
    ! SUBROUTINE RLUXIN(ISDEXT)
    ! ranlux.f Rev 1.2  1997/09/22 13:45:47  mclareni
    ! Correct error in initializing RANLUX by using RLUXIN with the
    ! output of RLUXUT from a previous run.
    ! CERN Mathlib gen
    ! ++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
    ! RLUXIN(ISVEC)    restarts the generator from vector   ++
    ! ISVEC of 25 32-bit integers (see RLUXUT)      ++
    ! ISVEC must be dimensioned 25 in the calling program        ++
    ! *******************************************************************
    subroutine rluxin(isdext)
      implicit real *8(a-h, o-z)
      dimension seeds(24), isdext(25)
      parameter(maxlev=4, lxdflt=3)
      dimension ndskip(0:maxlev)
      dimension next(24)
      parameter(twop12=4096., igiga=1000000000, jsdflt=314159265)
      parameter(itwo24=2**24, icons=2147483563)
      save notyet, i24, j24, carry, seeds, twom24, twom12, luxlev
      save nskip, ndskip, in24, next, kount, mkount, inseed
      integer luxlev
      logical notyet
      data notyet, luxlev, in24, kount, mkount/.true., lxdflt, 0, 0, 0/
      data i24, j24, carry/24, 10, 0./
      ! default
      ! Luxury Level   0     1     2   *3*    4
      data ndskip/0, 24, 73, 199, 365/
      ! orresponds to p=24    48    97   223   389
      ! time factor 1     2     3     6    10   on slow workstation
      ! 1    1.5    2     3     5   on fast mainframe


      ! Entry to input and float integer seeds from previous run
      notyet = .false.
      twom24 = 1.
      do i = 1, 24
        next(i) = i - 1
        twom24 = twom24*0.5
      end do
      next(1) = 24
      twom12 = twom24*4096.
      write (16, '(A)') 'FULL INITIALIZATION OF RANLUX WITH 25', ' INTEGERS'
      write (16, '(5X,5I12)') isdext
      do i = 1, 24
        seeds(i) = real(isdext(i))*twom24
      end do
      carry = 0.
      if (isdext(25)<0) carry = twom24
      isd = iabs(isdext(25))
      i24 = mod(isd, 100)
      isd = isd/100
      j24 = mod(isd, 100)
      isd = isd/100
      in24 = mod(isd, 100)
      isd = isd/100
      luxlev = isd
      if (luxlev<=maxlev) then
        nskip = ndskip(luxlev)
        write (6, '(A,I2)') 'RANLUX LUXURY LEVEL SET BY RLUXIN TO: ', luxlev
      else if (luxlev>=24) then
        nskip = luxlev - 24
        write (6, '(A,I5)') 'RANLUX P-VALUE SET BY RLUXIN TO:', luxlev
      else
        nskip = ndskip(maxlev)
        write (6, '(A,I5)') 'RANLUX ILLEGAL LUXURY RLUXIN: ', luxlev
        luxlev = maxlev
      end if
      inseed = -1
      return
    end subroutine rluxin
    ! *******************************************************************
    ! SUBROUTINE RLUXUT(ISDEXT)
    ! CERN Mathlib gen
    ! ++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
    ! CALL RLUXUT(ISVEC)    outputs the current values of the 25 ++
    ! 32-bit integer seeds, to be used for restarting ++
    ! ISVEC must be dimensioned 25 in the calling program        ++
    ! *******************************************************************
    subroutine rluxut(isdext)
      implicit real *8(a-h, o-z)
      dimension seeds(24), isdext(25)
      parameter(maxlev=4, lxdflt=3)
      dimension ndskip(0:maxlev)
      parameter(twop12=4096., igiga=1000000000, jsdflt=314159265)
      parameter(itwo24=2**24, icons=2147483563)
      save notyet, i24, j24, carry, seeds, luxlev
      save ndskip, in24, kount, mkount
      integer luxlev
      logical notyet
      data notyet, luxlev, in24, kount, mkount/.true., lxdflt, 0, 0, 0/
      data i24, j24, carry/24, 10, 0./
      ! default
      ! Luxury Level   0     1     2   *3*    4
      data ndskip/0, 24, 73, 199, 365/
      ! orresponds to p=24    48    97   223   389
      ! time factor 1     2     3     6    10   on slow workstation
      ! 1    1.5    2     3     5   on fast mainframe


      ! Entry to output seeds as integers
      do i = 1, 24
        isdext(i) = int(seeds(i)*twop12*twop12)
      end do
      isdext(25) = i24 + 100*j24 + 10000*in24 + 1000000*luxlev
      if (carry>0.) isdext(25) = -isdext(25)
      return
    end subroutine rluxut
    ! *******************************************************************
    ! SUBROUTINE RLUXAT(LOUT,INOUT,K1,K2)
    ! CERN Mathlib gen
    ! ++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
    ! CALL RLUXAT(LUX,INT,K1,K2) gets the values of four integers++
    ! which can be used to restart the RANLUX generator ++
    ! at the current point by calling RLUXGO.  K1 and K2++
    ! specify how many numbers were generated since the ++
    ! initialization with LUX and INT.  The restarting  ++
    ! skips over  K1+K2*E9   numbers, so it can be long.++
    ! ISVEC must be dimensioned 25 in the calling program        ++
    ! *******************************************************************
    subroutine rluxat(lout, inout, k1, k2)
      implicit real *8(a-h, o-z)
      parameter(maxlev=4, lxdflt=3)
      save notyet, luxlev
      save in24, kount, mkount, inseed
      integer luxlev
      logical notyet
      data notyet, luxlev, in24, kount, mkount/.true., lxdflt, 0, 0, 0/
      ! Entry to output the "convenient" restart point
      lout = luxlev
      inout = inseed
      k1 = kount
      k2 = mkount
      return
    end subroutine rluxat
    ! *******************************************************************
    ! SUBROUTINE RLUXGO(LUX,INS,K1,K2)
    ! CERN Mathlib gen
    ! ++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
    ! CALL RLUXGO(LUX,INT,K1,K2) initializes the generator from  ++
    ! one 32-bit integer INT and sets Luxury Level LUX  ++
    ! which is integer between zero and MAXLEV, or if   ++
    ! LUX .GT. 24, it sets p=LUX directly.  K1 and K2   ++
    ! should be set to zero unless restarting at a break++
    ! point given by output of RLUXAT (see RLUXAT).     ++
    ! ISVEC must be dimensioned 25 in the calling program        ++
    ! *******************************************************************
    subroutine rluxgo(lux, ins, k1, k2)
      implicit real *8(a-h, o-z)
      dimension seeds(24), iseeds(24)
      parameter(maxlev=4, lxdflt=3)
      dimension ndskip(0:maxlev)
      dimension next(24)
      parameter(twop12=4096., igiga=1000000000, jsdflt=314159265)
      parameter(itwo24=2**24, icons=2147483563)
      save notyet, i24, j24, carry, seeds, twom24, twom12, luxlev
      save nskip, ndskip, in24, next, kount, mkount, inseed
      integer luxlev
      logical notyet
      data notyet, luxlev, in24, kount, mkount/.true., lxdflt, 0, 0, 0/
      data i24, j24, carry/24, 10, 0./
      ! default
      ! Luxury Level   0     1     2   *3*    4
      data ndskip/0, 24, 73, 199, 365/
      ! orresponds to p=24    48    97   223   389
      ! time factor 1     2     3     6    10   on slow workstation
      ! 1    1.5    2     3     5   on fast mainframe


      ! Entry to initialize from one or three integers
      if (lux<0) then
        luxlev = lxdflt
      else if (lux<=maxlev) then
        luxlev = lux
      else if (lux<24 .or. lux>2000) then
        luxlev = maxlev
        write (6, '(A,I7)') 'RANLUX ILLEGAL LUXURY RLUXGO: ', lux
      else
        luxlev = lux
        do ilx = 0, maxlev
          if (lux==ndskip(ilx)+24) luxlev = ilx
        end do
      end if
      if (luxlev<=maxlev) then
        nskip = ndskip(luxlev)
        write (16, '(A,I2,A,I4)') 'RANLUX LUXURY LEVEL SET BY RLUXGO :', luxlev, '     P=', nskip + 24
      else
        nskip = luxlev - 24
        write (16, '(A,I5)') 'RANLUX P-VALUE SET BY RLUXGO TO:', luxlev
      end if
      in24 = 0
      if (ins<0) write (6, '(A)') ' Illegal initialization by RLUXGO, negative input seed'
      if (ins>0) then
        jseed = ins
        write (16, '(A,3I12)') 'RANLUX INITIALIZED BY ', 'RLUXGO FROM SEEDS', jseed, k1, k2
      else
        jseed = jsdflt
        write (16, '(A)') 'RANLUX INITIALIZED BY RLUXGO FROM DEFAULT', ' SEED'
      end if
      inseed = jseed
      notyet = .false.
      twom24 = 1.
      do i = 1, 24
        twom24 = twom24*0.5
        k = jseed/53668
        jseed = 40014*(jseed-k*53668) - k*12211
        if (jseed<0) jseed = jseed + icons
        iseeds(i) = mod(jseed, itwo24)
      end do
      twom12 = twom24*4096.
      do i = 1, 24
        seeds(i) = real(iseeds(i))*twom24
        next(i) = i - 1
      end do
      next(1) = 24
      i24 = 24
      j24 = 10
      carry = 0.
      if (seeds(24)==0.) carry = twom24
      ! If restarting at a break point, skip K1 + IGIGA*K2
      ! Note that this is the number of numbers delivered to
      ! the user PLUS the number skipped (if luxury .GT. 0).
      kount = k1
      mkount = k2
      if (k1+k2/=0) then
        do iouter = 1, k2 + 1
          inner = igiga
          if (iouter==k2+1) inner = k1
          do isk = 1, inner
            uni = seeds(j24) - seeds(i24) - carry
            if (uni<0.) then
              uni = uni + 1.0
              carry = twom24
            else
              carry = 0.
            end if
            seeds(i24) = uni
            i24 = next(i24)
            j24 = next(j24)
          end do
        end do
        ! Get the right value of IN24 by direct calculation
        in24 = mod(kount, nskip+24)
        if (mkount>0) then
          izip = mod(igiga, nskip+24)
          izip2 = mkount*izip + in24
          in24 = mod(izip2, nskip+24)
        end if
        ! Now IN24 had better be between zero and 23 inclusive
        if (in24>23) then
          write (6, '(A/A,3I11,A,I5)') '  Error in RESTARTING with RLUXGO:', ' The values', ins, k1, k2, &
            ' cannot occur at luxury level', luxlev
          in24 = 0
        end if
      end if
      return
    end subroutine rluxgo
    ! *******************************************************************
    ! SUBROUTINE gcern(len,s,am,v)
    ! generateur aleatoire selon une loi normale
    ! s : ecart-type de la distribution
    ! am: moyenne de ladistribution
    ! v : nombre aléatoire selon la loi normale
    ! *******************************************************************
    subroutine gcern(len, s, am, v)
      implicit real *8(a-h, o-z)
      common /ragau/ntir
      dimension vecx(1)

      a = 0.
      do i = 1, ntir
        call rlux(vecx, len)
        y = vecx(1)
        a = a + y
      end do
      v = (a-float(ntir)/2.)*s + am
      return
    end subroutine gcern
    ! *******************************************************************
    ! SUBROUTINE adjrfq
    ! read the coordinates of particles from file
    ! *******************************************************************
    subroutine adjrfq
      implicit real *8(a-h, o-z)
      parameter(iptsz=100002, maxcell=3000, maxcell1=3000)
      common /consta/vl, pi, xmat, rpel, qst
      common /davcom/dav1(maxcell1, 40), davtot, iitem(maxcell1), idav
      common /speda/dave, idave
      common /dyn/tref, vref
      common /faisc/f(10, iptsz), imax, ngood
      common /objet/fo(9, iptsz), imaxo
      common /qmoyen/qmoy
      common /rigid/boro
      common /sc3/beamc, scdist, sce10, cplm, ect, apl, ichaes, iscsp
      common /etcom/cog(8), exten(17), fd(iptsz)
      common /tapes/in, ifile, meta
      common /isxpyp/iflag
      common /mcs/imcs, ncstat, cstat(20)
      common /ttfc/tk, t1k, t2k, sk, s1k, s2k, fh
      common /dyni/vrefi, trefi, fhinit, acpt
      common /strip/atm, qs, atms, ths, qop, sqst(6), anp, nqst
      common /trace3d/trace3h(100), trace3t(maxcell1), tif, kt3h, kt3t, fid
      common /trace3e/tracebi(6), traceei(3)
      common /t3dfld/fldctr(15), zend(15), t3d
      logical t3d
      character *128 trace3h, trace3t, tif
      logical dave

      read (in, *) iflag
      if (iflag==0 .or. iflag==100) write (16, *) 'Standard file, phase in rad'
      if (iflag==1 .or. iflag==101) write (16, *) 'File with charge state and rest ', 'mass, phase in rad'
      if (iflag==2 .or. iflag==102) write (16, *) 'File with several charge states', ', phase in rad'
      if (iflag==10 .or. iflag==110) write (16, *) 'Standard file, phase in ns'
      if (iflag==11 .or. iflag==111) write (16, *) 'File with charge state and rest', ' mass, phase in ns'
      if (iflag==12 .or. iflag==112) write (16, *) 'File with several charge states', ', phase in ns'
      ! ---  input: freq.(MHertz) tofini: phase offset (deg) to be applied both to the reference and the beam
      read (in, *) freq, tofini
      write (16, *) 'Frequency [MHz]:', freq
      fh = 2.*pi*freq*1.e06
      fhinit = fh
      read (in, *) uem, atm
      xmat = uem*atm
      ! --- reference:
      ! enedep:energy(MeV), qst: charge of the reference
      ! when iflag =0 or iflag = 1 qst is the charge of the beam
      read (in, *) enedep, qst
      tofini = tofini*pi/(180.*fh)
      gdep = enedep/xmat + 1.
      bdep = sqrt(1.-1./(gdep*gdep))
      vref = bdep*vl
      vrefi = vref
      tref = tofini
      trefi = tofini
      ncstat = 1
      boro = 3.3356*xmat*bdep*gdep/qst
      write (16, 101) uem, atm, qst, tofini, enedep, boro
101   format (' **** unit mass: ', e12.5, ' MeV, mass units: ', f6.1, /, ' **** reference charge ', f4.1, &
        ' time of flight ', e12.5, ' sec', /, ' **** reference : energy ', e12.5, ' MeV  momentum ', e12.5, ' kG.cm')

      read (55, *) imax, dum, dum
      if (imax+2>iptsz) then
        write (16, *) 'too many particles '
        stop
      end if
      ! iflag = 0 standard file:f(1,)=x, f(2,)=xp, f(3,)=y, f(4,)=yp, f(5,)=phase, f(6,)=kinetic energy
      if (iflag==0 .or. iflag==10) read (55, *)((f(i,j),i=1,6), j=1, imax)
      ! iflag = 1  File with rest mass: f(1,)=x, f(2,)=xp, f(3,)=y, f(4,)=yp, f(5,)=phase, f(6,)=kinetic energy, dum1,
      ! dum2
      if (iflag==1 .or. iflag==11) read (55, *)((f(i,j),i=1,6), dum1, dum2, j=1, imax)
      ! iflag = 2 beam with different charges: f(7,) = charge; figure out how many different ones there are and store
      ! them
      if (ncstat==1) cstat(1) = qst
      if (iflag==2 .or. iflag==12) then
        ncstat = 1
        read (55, *)(f(i,1), i=1, 7)
        cstat(1) = f(7, 1)
        do j = 2, imax
          read (55, *)(f(i,j), i=1, 7)
          mcstat = 0
          do k = 1, ncstat
            if (f(7,j)==cstat(k)) then
              mcstat = 1
            end if
          end do
          if (mcstat==0) then
            ncstat = ncstat + 1
            cstat(ncstat) = f(7, j)
          end if
        end do
        write (16, *) 'Number of charge states: ', ncstat
        write (16, *) 'Charge states: ', (cstat(j), j=1, ncstat)
        if (ncstat>1) imcs = 1
      end if
      call intfac(tofini)
      if (t3d) then
        tracebi(6) = tracebi(6)*sqrt(atm)
        write (tif, 901)(tracebi(i), i=1, 6)
901     format (' BEAMI(1)= ', 5(f12.6,1x), f12.4)
        kt3h = kt3h + 1
        trace3h(kt3h) = tif
        traceei(3) = traceei(3)/sqrt(atm)
        write (tif, 902)(traceei(i), i=1, 3)
902     format (' EMITI(1)= ', f12.6, 1x, f12.6, 1x, f12.4)
        kt3h = kt3h + 1
        trace3h(kt3h) = tif
        write (tif, 903) uem*atm/qst, fhinit/2./pi/1.e6
903     format (' ER= ', e16.7, ', Q=1 FREQ= ', e14.7)
        kt3h = kt3h + 1
        trace3h(kt3h) = tif
        write (tif, 7001) enedep/qst
7001    format (' W= ', f12.4)
        kt3h = kt3h + 1
        trace3h(kt3h) = tif
      end if
      return
    end subroutine adjrfq
    ! *******************************************************************
    ! SUBROUTINE intfac(tofini)
    ! convert the particles coordinates to DYNAC units
    ! *******************************************************************
    subroutine intfac(tofini)
      implicit real *8(a-h, o-z)
      parameter(iptsz=100002, maxcell=3000, maxcell1=3000)
      common /etcom/cog(8), exten(17), fd(iptsz)
      common /shif/dtiph, shift
      common /ttfc/tk, t1k, t2k, sk, s1k, s2k, fh
      common /faisc/f(10, iptsz), imax, ngood
      common /objet/fo(9, iptsz), imaxo
      common /qmoyen/qmoy
      common /rigid/boro
      common /dyn/tref, vref
      common /consta/vl, pi, xmat, rpel, qst
      common /tapes/in, ifile, meta
      common /etcha1/dav2(maxcell1, 33), ichas(iptsz), chasit
      common /davcom/dav1(maxcell1, 40), davtot, iitem(maxcell1), idav
      common /sc3/beamc, scdist, sce10, cplm, ect, apl, ichaes, iscsp
      common /speda/dave, idave
      common /isxpyp/iflag
      common /mcs/imcs, ncstat, cstat(20)
      dimension foo(20, 9), ndp(20)
      common /trace3d/trace3h(100), trace3t(maxcell1), tif, kt3h, kt3t, fid
      common /trace3e/tracebi(6), traceei(3)
      common /t3dfld/fldctr(15), zend(15), t3d
      logical t3d
      character *128 trace3h, trace3t, tif
      logical shift, chasit, dave
      ! FH :INITIAL FREQENCY (hertz)
      ! Use frequency from part. dist. file to calculate f(6,i)
      ! iflag = 0 : standard file, phase in rad
      ! iflag = 1 : special file, phase in rad
      ! iflag = 2 : several charge states, phase in rad
      ! iflag = 10 : standard file, phase in ns
      ! iflag = 11 : special file, phase in ns
      ! iflag = 12 : several charge states, phase in ns
      imcs = 0
      if (iflag==2 .or. iflag==12) imcs = 1
      qmoy = qst
      j = 1
      ! the table fo(,) is built from the input beam stored in the table f(,)
      if (iflag<=2) then
        do i = 1, imax
          fo(7, i) = f(6, j) + xmat
          if (iflag<=1) fo(9, i) = qst
          if (iflag==2) fo(9, i) = f(7, i)
          ichas(i) = 1
          fo(8, i) = 1.
          fo(1, i) = float(j+1)
          fo(2, i) = f(1, j)
          fo(3, i) = f(2, j)*1000.
          fo(4, i) = f(3, j)
          fo(5, i) = f(4, j)*1000.
          fo(6, i) = tofini + f(5, j)/fh
          j = j + 1
        end do
      else
        do i = 1, imax
          fo(7, i) = f(6, j) + xmat
          if (iflag<=11) fo(9, i) = qst
          if (iflag==12) fo(9, i) = f(7, i)
          ichas(i) = 1
          fo(8, i) = 1.
          fo(1, i) = float(j+1)
          fo(2, i) = f(1, j)
          fo(3, i) = f(2, j)*1000.
          fo(4, i) = f(3, j)
          fo(5, i) = f(4, j)*1000.
          fo(6, i) = tofini + f(5, j)*1.e-09
          j = j + 1
        end do
      end if
      ! cog of the beam
      if (iflag==0 .or. iflag==1 .or. iflag==10 .or. iflag==11) then
        ! single charge state
        ndp(1) = imax
        do j = 2, 7
          foo(1, j) = 0.
        end do
        do i = 1, imax
          do j = 2, 7
            foo(1, j) = foo(1, j) + fo(j, i)
          end do
        end do
      else
        ! multi charge state
        kt3h = kt3h + 1
        trace3h(kt3h) = 'ERROR: RDBEAM reads more than 1 charge state'
        do k = 1, ncstat
          ndp(k) = 0
          do j = 2, 7
            foo(k, j) = 0.
          end do
        end do
        do i = 1, imax
          do k = 1, ncstat
            if (fo(9,i)==cstat(k)) then
              ndp(k) = ndp(k) + 1
              do j = 2, 7
                foo(k, j) = foo(k, j) + fo(j, i)
              end do
            end if
          end do
        end do
      end if
      do k = 1, ncstat
        do j = 2, 7
          foo(k, j) = foo(k, j)/float(ndp(k))
        end do
      end do
      ngood = imax
      if (iflag==0 .or. iflag==1 .or. iflag==10 .or. iflag==11) then
        ! --- COG
        gref = foo(1, 7)/xmat
        bref = sqrt(1.-1./(gref*gref))
        xe = (gref-1.)*xmat
        ! magnetic rigidity
        bor = 3.3356*xmat*bref*gref/qst
        write (16, *) '**** COG : energy ', xe, ' MeV  momentum ', boro, ' kG.cm'
      else
        do k = 1, ncstat
          gref = foo(k, 7)/xmat
          bref = sqrt(1.-1./(gref*gref))
          xe = (gref-1.)*xmat
          ! magnetic rigidity
          bor = 3.3356*xmat*bref*gref/cstat(k)
          write (16, *) ' Q: ', cstat(k), ' COG : energy ', xe, ' MeV  momentum ', bor, ' kG.cm'
        end do
      end if
      vrefi = vref
      trefi = tref
      ! now save data back to f
      do i = 1, ngood
        do k = 1, 9
          f(k, i) = fo(k, i)
        end do
      end do
      ! 9999   format(6(2x,e12.5))
      imaxo = ngood
      call emiprt(0)
      if (t3d) then
        call emit3d
      end if
      return
    end subroutine intfac
    ! *******************************************************************
    ! SUBROUTINE stapl(zpos)
    ! the statistics in EXT2

    ! sprfx(cm): 2.*sqrt( sum(x*x) )
    ! sprfy(cm): 2.*sqrt( sum(y*y) )
    ! sprfw:     2.*sqrt( sum(dp/p * dp/p) )*beta*beta =
    ! (energy spread)/(energy of c.o.g)
    ! sprfp(deg):2.*sqrt( sum(dphi * dphi) )
    ! sprfz(cm) :   sqrt( sum(dt * dt) )
    ! sprfl(m) : t.o.f of the reference
    ! sprww(MeV):kinetic energy of the c.o.g
    ! eprfw(ns.keV) : longitudinal emittance
    ! eprnx(mm.mrad): normalized emittance in x-direction
    ! eprny(mm.mrad): normalized emittance in y-direction
    ! *******************************************************************
    subroutine stapl(zpos)
      implicit real *8(a-h, o-z)
      parameter(iptsz=100002, maxcell=3000, maxcell1=3000)
      common /pltprf/sprfx(3000), sprfy(3000), sprfl(3000), sprfw(3000), sprfp(3000), sprng(3000), iprf
      common /pltprf1/sprww(3000), eprfw(3000), eprnx(3000), eprny(3000), sprfz(3000)
      common /pltprf2/sxmn(3000), sxmx(3000), symn(3000), symx(3000), stmn(3000), stmx(3000), spmn(3000), spmx(3000), &
        swmn(3000), swmx(3000), disprx(3000), dispry(3000), dispcx(3000), dispcy(3000)
      common /etcom/cog(8), exten(17), fd(iptsz)
      common /consta/vl, pi, xmat, rpel, qst
      common /ttfc/tk, t1k, t2k, sk, s1k, s2k, fh
      common /faisc/f(10, iptsz), imax, ngood
      common /grot/rzot, izrot
      logical izrot
      ! izrot: logical flag set as .true. in the routine ZROTA
      if (izrot) call zrotap(-rzot)
      iarg = 0
      call cdg(iarg)
      encog = cog(1)
      gcog = encog/xmat
      bcog = sqrt(1.-1./(gcog*gcog))
      tcog = cog(3)
      call ext2(iarg)
      qdisp = 2.*sqrt(exten(1))
      qmd = exten(1)*exten(3) - exten(2)*exten(2)
      delw = encog*encog*bcog**4
      qmdv = qmd*delw
      sqmdv = 4.*pi*sqrt(qmdv)
      eprfw(iprf) = sqmdv*1.e12/(pi*fh)
      sprfx(iprf) = 2.*sqrt(exten(4))
      sprfy(iprf) = 2.*sqrt(exten(6))
      trqtx = exten(4)*exten(5) - exten(8)*exten(8)
      trqpy = exten(6)*exten(7) - exten(9)*exten(9)
      surxth = 4.*pi*sqrt(trqtx)
      suryph = 4.*pi*sqrt(trqpy)
      eprnx(iprf) = bcog*surxth*10./(pi*sqrt(1.-bcog*bcog))
      eprny(iprf) = bcog*suryph*10./(pi*sqrt(1.-bcog*bcog))
      ! horizontal and vertical dispersion in meter (w.r.t. reference)
      ! disprx(iprf)=0.01*exten(12)/exten(14)
      ! dispry(iprf)=0.01*exten(13)/exten(14)
      ! horizontal and vertical dispersion in meter (w.r.t. COG)
      dispcx(iprf) = 0.01*exten(15)/exten(17)
      dispcy(iprf) = 0.01*exten(16)/exten(17)
      trqfi = 0.
      tof = 0.
      chxmx = f(2, 1)
      chxmn = f(2, 1)
      chymx = f(4, 1)
      chymn = f(4, 1)
      chpmx = f(6, 1) - tcog
      chpmn = f(6, 1) - tcog
      chwmx = f(7, 1) - encog
      chwmn = f(7, 1) - encog
      do i = 1, ngood
        gpai = f(7, i)/xmat
        bpai = sqrt(1.-1./(gpai*gpai))
        fdp = (gpai*bpai)/(gcog*bcog) - 1.
        trqfi = trqfi + fdp*fdp
        tf = (tcog-f(6,i))*bpai*vl
        tof = tof + tf*tf
        if (f(2,i)>chxmx) chxmx = f(2, i)
        if (f(2,i)<chxmn) chxmn = f(2, i)
        if (f(4,i)>chymx) chymx = f(4, i)
        if (f(4,i)<chymn) chymn = f(4, i)
        if (f(6,i)-tcog>chpmx) then
          chpmx = f(6, i) - tcog
          chdmx = chpmx*fh*180./pi
        end if
        if (f(6,i)-tcog<chpmn) then
          chpmn = f(6, i) - tcog
          chdmn = chpmn*fh*180./pi
        end if
        if (f(7,i)-encog>chwmx) chwmx = f(7, i) - encog
        if (f(7,i)-encog<chwmn) chwmn = f(7, i) - encog
      end do
      trqfi = trqfi/float(ngood)
      tof = tof/float(ngood)
      sprfz(iprf) = sqrt(tof)
      cmult = (gcog+1.)/gcog
      sprfw(iprf) = 2.*sqrt(trqfi)*cmult
      sprfp(iprf) = 2.*sqrt(exten(3))*180./pi
      sprww(iprf) = cog(1) - xmat
      ! t.o.f of the reference in m
      sprfl(iprf) = zpos/1000.
      sprng(iprf) = ngood
      ! *et*2014-Sep-25 Add recording of min. and max. positions in x,y and z,z'
      sxmx(iprf) = chxmx*10.
      sxmn(iprf) = chxmn*10.
      symx(iprf) = chymx*10.
      symn(iprf) = chymn*10.
      stmx(iprf) = chpmx
      stmn(iprf) = chpmn
      spmx(iprf) = chdmx
      spmn(iprf) = chdmn
      swmx(iprf) = chwmx
      swmn(iprf) = chwmn
      ! evolve pointer iprf
      iprf = iprf + 1
      if (izrot) call zrotap(-rzot)
      return
    end subroutine stapl
    ! *******************************************************************
    ! SUBROUTINE eugwrt
    ! This routine writes the dynac.print file
    ! *******************************************************************
    subroutine eugwrt
      implicit real *8(a-h, o-z)
      common /pltprf/sprfx(3000), sprfy(3000), sprfl(3000), sprfw(3000), sprfp(3000), sprng(3000), iprf
      common /pltprf1/sprww(3000), eprfw(3000), eprnx(3000), eprny(3000), sprfz(3000)
      common /pltprf2/sxmn(3000), sxmx(3000), symn(3000), symx(3000), stmn(3000), stmx(3000), spmn(3000), spmx(3000), &
        swmn(3000), swmx(3000), disprx(3000), dispry(3000), dispcx(3000), dispcy(3000)
      ! l(m) x(mm) y(mm) z(deg) z(mm) Ex(mm.mrd) Ey(mm.mrd) Ez(KeV.ns) Wcog(MeV) xmin(mm) xmax(mm) ymin(mm) ymax(mm)
      ! tmin(ns) tmax(ns) pmin(deg) pmax(deg) wmin(MeV) wmax(MeV) Dxref(m) Dyref(m) Dxcog(m) Dycog(m)
      write (71, 99)
99    format (1x, '#    l(m)  ', 1x, '     x(mm)  ', 1x, '     y(mm)  ', 3x, '    z(deg) ', 1x, '     z(mm)  ', 2x, &
        'emx(mm.mrd)', 2x, 'emy(mm.mrd) ', 1x, 'emz(KeV.ns)', 2x, 'energy(MeV) ', 1x, '#particles', 2x, 'xmin(mm)', 5x, &
        'xmax(mm)', 5x, 'ymin(mm)', 5x, 'ymax(mm)', 5x, 'tmin(s)', 6x, 'tmax(s)', 5x, 'phmin(deg)', 4x, 'phmax(deg)', &
        3x, 'Wmin(MeV)', 4x, 'Wmax(MeV)', 4x, 'Dx(m)', 8x, 'Dy(m)')
      iprf1 = iprf - 1
      do i = 1, iprf1
        ! x and y: cm-->mm
        sprx = sprfx(i)*10./2.
        spry = sprfy(i)*10./2.
        sprp = sprfp(i)/2.
        sprz = sprfz(i)*10.
        write (71, 100) sprfl(i), sprx, spry, sprp, sprz, eprnx(i)/4., eprny(i)/4., eprfw(i), sprww(i), int(sprng(i)), &
          sxmn(i), sxmx(i), symn(i), symx(i), stmn(i), stmx(i), spmn(i), spmx(i), swmn(i), swmx(i), dispcx(i), dispcy(i)
        ! *               disprx(i),dispry(i),dispcx(i),dispcy(i)
      end do
100   format (9(1x,e12.5), 1x, i7, 3x, 12(1x,e12.5))
      ! 100    format(9(1x,e12.5),1x,i7,3x,14(1x,e12.5))
      return
    end subroutine eugwrt
    ! *******************************************************************
    ! SUBROUTINE etgap
    ! single cell of a DTL (CAVSC)

    ! etcell(1)=cell#, etcell(2)=energy (MeV), etcell(3)=beta
    ! etcell(4)=cell length (cm), etcell(5)=T, etcell(6)=TP,
    ! etcell (7)=S, etcell(8)=SP
    ! etcell(9)=quad length (cm), etcell (10)=quad. strength (kG/cm),
    ! etcell(11)=Eo (MV/m), etcell(12)= phase of RF at middle(deg),
    ! etcell(13)= actual length(cm), etcell(14)=TPP,
    ! etcell(15)=frequency (MHz), etcell(16)=field factor
    ! *******************************************************************
    subroutine etgap
      implicit real *8(a-h, o-z)
      parameter(iptsz=100002, maxcell=3000, maxcell1=3000)
      common /ttfs/dynt(maxcell), dyntp(maxcell), dyntpp(maxcell), dyne0(maxcell), dynph(maxcell), dynlg(maxcell), &
        fhpar, nc
      common /posi/ist
      common /midgap/enmil, vapmi
      common /azmtch/dlg, xmcph, xmce
      common /azlist/icont, iprin
      common /itvole/itvol, imamin
      common /func/a(200), ylg, atte, ncel, nharm
      ! TRANSIT TIME COEFFICIENTS
      common /ttfc/tk, t1k, t2k, sk, s1k, s2k, fh
      common /ttfc1/t3k, t4k, s3k, s4k
      common /bedycp/phslip, eqvl, asdl, peqvl, pavph, xkp1, xkp2, aa, bb, cc, dd, ee, pcrest, sqcttf
      common /jacob/gaks, gaps
      common /iter1/dxdki, dphii, phi, dkmske, dkmsphi, retph, xkmi, xkm, dxk00, tke, t1ke, ske, s1ke, phiwc, xk1i, &
        xk1ii, xk2ii
      common /faisc/f(10, iptsz), imax, ngood
      common /qmoyen/qmoy
      common /rigid/boro
      common /cdek/dwp(iptsz)
      common /sc3/beamc, scdist, sce10, cplm, ect, apl, ichaes, iscsp
      common /consta/vl, pi, xmat, rpel, qst
      common /dyn/tref, vref
      common /compt/nrres, nrtre, nrbunc, nrdbun
      common /compt1/ndtl, ncavmc, ncavnm
      common /fene/wdisp, wphas, wx, wy, rlim, ifw
      common /tapes/in, ifile, meta
      common /ranec1/dummy(6)
      common /etcom/cog(8), exten(17), fd(iptsz)
      common /speda/dave, idave
      common /shif/dtiph, shift
      common /davcom/dav1(maxcell1, 40), davtot, iitem(maxcell1), idav
      common /etcha1/dav2(maxcell1, 33), ichas(iptsz), chasit
      common /dcspa/iesp
      common /fct/fakt
      common /mode/eflvl, rflvl
      common /pltprf/sprfx(3000), sprfy(3000), sprfl(3000), sprfw(3000), sprfp(3000), sprng(3000), iprf
      common /appel/irstay, ilost, iavp, ispcel
      common /posc/xpsc
      common /femt/iemgrw, iemqesg
      common /aerp/vphase, vfield, ierpf
      common /tofev/ttvols
      common /pstpla/tstp
      common /trace3d/trace3h(100), trace3t(maxcell1), tif, kt3h, kt3t, fid
      character *128 trace3h, trace3t, tif
      ! --- synchronous particle:
      ! *****     DWRFS(MeV): energy gain
      ! *****     SPHRFS(rad): phase jump
      ! *****     PHRFS(rad):phase RF
      ! *****       common/parmrf/DWRFS,SPHRFS,PHRFS,ngdrf
      logical iesp, irstay, iavp, ispcel, iemgrw
      character *1 cr
      ! SHIFT =TRUE: cog and synchronous particle are independent
      ! SHIFT =FALSE: cog and synchronous particle are coinciding
      logical shift, chasit, itvol, imamin, dave, ichaes
      dimension etcell(maxcell)
      ! --- iesp, irstay, ispcel logical flags used in the routines of space sharge computations
      ! iesp=false: accelerating element
      ! ispcel = .true.: space charge computation
      iesp = .false.
      irstay = .false.
      ispcel = .true.
      ilost = 0
      fact = 1.
      ndtl = ndtl + 1
      nrres = nrres + 1
      ! allow for print out on terminal of gap# on one and the same line
      cr = char(13)
      write (6, 8254) nrtre, ndtl, cr
8254  format ('Transport element:', i5, '      Accelerating gap    :', i5, a1, $)
      write (16, *) 'ACCELERATING GAP N :', ndtl
      read (in, *)(etcell(iet), iet=1, 16)
      fh = etcell(15)
      fakt = etcell(16)
      if (fakt==0.) fakt = 1.e-12
      fh = fh*2.*pi*1000000.
      ! --- YLG : CELL LENGTH (cm)
      ! --- YE0 : ELECTRIC FIELD (MV/cm)
      ylg = etcell(4)
      scdist = ylg
      ye0 = etcell(11)/100.
      ! TRANSIT TIME COEFFICIENTS (at the middle OF THE CELL)
      t0 = etcell(5)*ylg*ye0
      tp0 = -etcell(6)*ylg*ylg*ye0
      tpp0 = -etcell(14)*ylg*ylg*ylg*ye0
      ! TRANSIT TIME factors at the ENTRANCE OF THE CELL
      ! with kg=2*PI/ylg:
      ! TK0=T0*COS(kg*ylg/2) = -T0
      ! SK0=T0*SIN(kg*ylg/2) = 0
      ! TPK0=d(TK0)/dk
      ! SPK0=d(SK0)/dk
      ! TPPK0=d(TPK0)/dk
      ! SPPK0=d(SPK0)/dk
      tk0 = -t0
      sk0 = 0.
      tpk0 = -tp0
      spk0 = -ylg*t0/2.
      tppk0 = ylg*ylg*t0/4. - tpp0
      sppk0 = -ylg*tp0/2.
      tk = tk0
      t1k = tpk0
      t2k = tppk0
      sk = sk0
      s1k = spk0
      s2k = sppk0
      tp3k0 = 0.
      tp4k0 = 0.
      sp3k0 = 0.
      sp4k0 = 0.
      ! MULTIPLY TRANSIT TIME factors WITH FAKT
      t0 = t0*fakt
      tp0 = tp0*fakt
      tpp0 = tpp0*fakt
      tk0 = -t0
      tpk0 = -tp0
      spk0 = -ylg*t0/2.
      tppk0 = ylg*ylg*t0/4. - tpp0
      sppk0 = -ylg*tp0/2.
      tk = tk0
      t1k = tpk0
      t2k = tppk0
      sk = sk0
      s1k = spk0
      s2k = sppk0
      ! IPOINR=IPOINR+1
      ! print in file: 'short.data'
      ! --- ylg : CELL LENGTH (cm) ==> (mm)
      ! --- ye0 : ELECTRIC FIELD (MV/cm) ==> (Kv/mm)
      ! --- davtot (mm)
      idav = idav + 1
      iitem(idav) = 17
      dav1(idav, 1) = ylg*10.
      dav1(idav, 2) = ye0*100.
      tstp = (davtot+ylg*xpsc)*10.
      davtot = davtot + ylg
      dav1(idav, 24) = davtot*10.
      ! 21.11.09       dav1(idav,40)=fh
      fh0 = fh/vl
      ! STATISTICS FOR PLOT
      if (iprf==1) call stapl(dav1(idav,24))
      ! reference particle
      iarg = 1
      call cdg(iarg)
      ecog = cog(1)
      enold = ecog
      gcog = ecog/xmat
      bcog = sqrt(1.-1./(gcog*gcog))
      tcog = cog(3)
      if (shift) then
        ! reference particle and cog are independent
        beref = vref/vl
        gamref = 1./sqrt(1.-(beref*beref))
        enref = xmat*gamref
        trefdg = tref*fh*180./pi
        tcogdg = tcog*fh*180./pi
        dav1(idav, 3) = 1.
      else
        ! reference and c.o.g. are coinciding
        vref = bcog*vl
        tref = tcog
        gamref = gcog
        beref = bcog
        enref = cog(1)
        trefdg = tref*fh*180./pi
        tcogdg = tcog*fh*180./pi
        dav1(idav, 3) = 0.
      end if
      ! --- ttvol: time of flight at entrance (sec)
      ttvol = 0.
      if (itvol) ttvol = ttvols*fh
      ! ***** reference is placed in the position ngdrf=ngood+1 in array f(10,i)
      ! *****         ngdrf=ngood+1
      ! *****         BEREF=VREF/VL
      ! *****         GAMREF=1./SQRT(1.-(BEREF*BEREF))
      ! *****         ENREF=XMAT*GAMREF
      ! ****         f(1,ngdrf)=ngdrf
      ! ****         f(2,ngdrf)=0.
      ! ****         f(3,ngdrf)=0.
      ! ****         f(4,ngdrf)=0.
      ! ****         f(5,ngdrf)=0.
      ! ****         f(6,ngdrf)=tref
      ! ****         f(7,ngdrf)=enref
      ! ****         f(8,ngdrf)=1.
      ! ****         f(9,ngdrf)=qst
      ! ****         f(10,ngdrf)=0.
      if (dav1(idav,3)==1.) write (16, *) ' ****reference and cog are different'
      if (dav1(idav,3)==0.) write (16, *) ' **** reference and cog coincide '
      write (16, 178)
178   format (/, ' DYNAMICS AT THE INPUT ', /, 5x, '   BETA     GAMMA      ENERGY(MeV) ', &
        '       TOF(deg)     TOF(sec)')
      write (16, 1788) bcog, gcog, ecog - xmat, tcogdg, tcog
1788  format (' COG ', f7.5, 3x, e12.5, 1x, e12.5, 3x, e12.5, 3x, e12.5)
      write (16, 165) beref, gamref, enref - xmat, trefdg, tref
165   format (' REF ', f7.5, 3x, e12.5, 1x, e12.5, 3x, e12.5, 3x, e12.5)
      tofprt = tref
      ! iprint=1: full print ( in case of pbmes)
      iprint = 0
      call statis
      xk1 = fh/vref
      ! ---  predictor of the average beta:BEMY.
      beref = vref/vl
      gamref = 1./sqrt(1.-(beref*beref))
      ! DPHASE : PHASE  AT THE MIDDLE OF THE CELL (rad)
      dphete = etcell(12)
      dphase = etcell(12)*pi/180.
      ! 15/12/09       dpherd=dphase
      ! 15/12/09       ttvol=0.
      ! --- The option TOF is passive in the DTL
      ! t.o.f. at the middle of the cell
      ! 15/12/09       if(itvol) then
      ! 15/12/09        tvolm=ylg/(2.*vref)
      ! 15/12/09        ttvol=(ttvols+tvolm)
      ! 15/12/09       endif
      ! 15/12/09 adjust the phase of RF w.r.t. TOF
      ! 15/12/09       if(itvol.and.imamin) then
      ! 15/12/09        odphase=dphase
      ! 15/12/09        ottvol=fh*ttvol*180./pi
      ! 15/12/09        attvol=ottvol
      ! 15/12/09        xkpi=ottvol/360.
      ! 15/12/09        ixkpi=int(xkpi)
      ! 15/12/09        xkpi=(xkpi-float(ixkpi))*360.
      ! 15/12/09        dphase=dphase-xkpi*pi/180.
      ! 15/12/09       endif
      aqst = abs(qst)
      ddw = aqst*t0*cos(dphase)
      enrefs = enref + ddw
      gams = enrefs/xmat
      bets = sqrt(1.-1./(gams*gams))
      xk2 = fh/(bets*vl)
      bemy = (gams*bets+gamref*beref)/(gams+gamref)
      xkm = fh/(bemy*vl)
      xkg = 2.*pi/ylg
      ! --- average phase of RF at entrance
      saphi = dphase
      sapho = saphi
      eqvl = ylg
      dkg = (xkm-xkg)
      dts = tp0/t0
      fk1 = 2.*dts
      fpk0 = (tp0*tp0+t0*tpp0)/(t0*t0)
      fpk1 = 2.*tp0**2/(t0*t0)
      fpk = 2.*(fpk0-fpk1)
      pcrest = atan(-sk/tk)
      ddw = aqst*(tk*cos(pcrest)-sk*sin(pcrest))/2.
      if (ddw<0.) pcrest = pcrest + pi
      peqvl = ylg/2.
      sclen = ylg
      ! 15/12/09       if(.not.imamin) then
      write (16, 1555) fh/(2.*pi), ylg, dphase*180./pi
1555  format (4x, 'FREQENCY :', e12.5, ' Hertz', /, 4x, 'GAP LENGTH :', e12.5, ' cm', /, 4x, &
        'PHASE of RF (middle of the gap)  :', e12.5, 'deg', /)
      ! 15/12/09       else
      ! 15/12/09        WRITE(16,1556)FH/(2.*pi),YLG,DPHASE*180./PI,odphase
      ! 15/12/09 1556    FORMAT(4X,'FREQENCY :',E12.5,' Hertz',/,4x,
      ! 15/12/09     x        'GAP LENGTH :',e12.5,' cm',/,4x,
      ! 15/12/09     x        'phase of RF after adjustement:',e12.5,'deg',/,4x,
      ! 15/12/09     *        'phase of RF before adjustment',e12.5,'deg')
      ! 15/12/09       endif
      ! ---  Follow ITERATIONS giving:
      ! The equivalent field length   (cm)
      ! The asociated drift length    (cm)
      ! The slip of phase             (rd)
      ! The energy gain               (MeV)
      ! The phase jump                (rd)
      ! The average k                 (cm-1)
      ! The transit time coefficients (MeV,cm)
      ! The phase crest               (rad)
      ! The phase offset at entrance  (rad)
      eqvl = ylg
      dkg = (xkm-xkg)
      fpk = 2.*(fpk0-fpk1)
      til2 = 0.
      do it = 1, 3
        ! slip of phase and equivalent field length
        if (it==1) phslip = -4.*atan(3.2*dts/eqvl)
        if (phslip/=0.) then
          til2 = phslip/2.
          do iiii = 1, 4
            gx = 1./tan(til2) - 1./til2
            gpx = -1./(sin(til2)*sin(til2)) + 1./(til2*til2)
            gppx = 2.*cos(til2)/(sin(til2)**3) - 2./(til2*til2*til2)
            hx = gpx/(gx*gx) - 2.*fpk/(fk1**2)
            dhx = -(2.*gx*gpx*gpx-gx*gx*gppx)/(gx**4)
            til2 = til2 - hx/dhx
            eqvl = sqrt(abs(2.*fpk/gpx))
            if (abs(hx)<=1.e-05) go to 556
          end do
556       continue
          phslip = til2*2.
        end if
        peqvl = ylg/2.
        asdl = peqvl - eqvl/2.
        ! ENERGY GAIN AND PHASE JUMP (i.e. DELPHR)
        ! saphi=sapho-pcrest+ttvol*fh
        saphi = sapho - pcrest + ttvol
        ! TESTsv05.05.2011         saphi=sapho-pcrest
        f0 = xitl0(gamref, gams, bemy, saphi, aqst)
        delwrm = (f0-gamref)*xmat
        enrs = enref + delwrm
        gams = enrs/xmat
        bets = sqrt(1.-1./(gams*gams))
        xk2 = fh0/bets
        coeph = fh*aqst/(vl*xmat)
        f2 = xitl2(gamref, gams, bemy, saphi, aqst)
        delphr = coeph*f2
        xkm = delphr/eqvl + xk2*(1.+asdl/eqvl) - xk1*asdl/eqvl
        bemy = fh0/xkm
        ! TRANSIT TIME FACTORS
        dkg = (xkm-xkg)
        tk = tk0 + dkg*tpk0 + dkg*dkg*tppk0/2. + dkg**3*tp3k0/6. + dkg**4*tp4k0/24.
        t1k = tpk0 + dkg*tppk0 + dkg*dkg*tp3k0/2. + dkg**3*tp4k0/6.
        t2k = tppk0 + dkg*tp3k0 + dkg*dkg*tp4k0/2.
        t3k = tp3k0 + dkg*tp4k0
        t4k = tp4k0
        sk = sk0 + dkg*spk0 + dkg*dkg*sppk0/2. + dkg**3*sp3k0/6. + dkg**4*sp4k0/24.
        s1k = spk0 + dkg*sppk0 + dkg*dkg*sp3k0/2. + dkg**3*sp4k0/6.
        s2k = sppk0 + dkg*sp3k0 + dkg*dkg*sp4k0/2.
        s3k = sp3k0 + dkg*sp4k0
        s4k = sp4k0
        ! PHASE CREST
        pcrest = atan(-sk/tk)
        ddw = aqst*(tk*cos(pcrest)-sk*sin(pcrest))/2.
        if (ddw<0.) pcrest = pcrest + pi
      end do
      ! CREST VALUE = SQCTTF*(PHSLIP/2)/SIN(PHSLIP/2)
      sqcttf = til2*sqrt(tk*tk+sk*sk)/sin(til2)*2.
      ! THE synchronous particle IS BASED ON CHARGE STATE : QMOY =AQST
      cfh = fh/(vl*2.*xmat)
      ckh = qmoy*qmoy/(4.*xmat*xmat)
      call gap(gamref, saphi, gams, delphr)
      ! output of the element
      ! new PHARES,TREFS to be in accordance with GENAC
      phares = saphi + fh*ylg/vref + delphr
      trefs = tref + ylg/(bets*vl) + delphr/fh
      phared = (phares-saphi)*180./pi
      tredg = fh*trefs*180./pi
      write (16, *) ' PARAMETERS RELATING TO THE REFERENCE PARTICLE '
      write (16, *) '************************************************'
      write (16, *) ' ENERGY GAIN(MeV): ', delwrm, ' TOF(DEG) ', tredg
      ! write(16,*) ' PHASE JUMP(DEG): ',sphrfs*180./PI
      write (16, *) ' CREST PHASE OF RF (DG): ', pcrest*180./pi
      write (16, *) ' PHASE OF RF AT THE MIDDLE (DG): ', sapho*180./pi
      write (16, *) ' PHASE OF RF AT THE ENTRANCE (DG): ', saphi*180./pi
      write (16, *) ' AVERAGE k (cm-1) (freq./velocity): ', xkm
      write (16, *) ' TRANSIT TIME FACTORS (MeV-cm):'
      write (16, *) ' T dT/dk d2T/dk2 ', tk, t1k, t2k
      write (16, *) ' S dS/dk d2S/dk2 ', sk, s1k, s2k
      write (16, *) ' PHASE SLIP(DEG) ', phslip*180./pi
      write (16, *)
      write (16, *) ' PARAMETERS RELATING TO THE EQUIVALENT FIELD '
      write (16, *) '************************************************'
      write (16, 171) eqvl
171   format (' length :', e12.5, ' cm ')
      write (16, *) ' Associated drift length: ', asdl, ' cm'
      write (16, *) ' magnitude: ', sqcttf, ' MV/cm'
      iarg = 1
      call cdg(iarg)
      encog = cog(1)
      gcog = encog/xmat
      bcog = sqrt(1.-1./(gcog*gcog))
      tcog = cog(3)
      call ext2d(1)
      ! sup        phnew=-(int(tcog*fh/pi+0.5)-tcog*fh/pi)*180.
      ! sup        dav1(idav,7)=phnew
      dav1(idav, 37) = saphi*180./pi
      ! 15/12/09        if(itvol) then
      ! 15/12/09        dav1(idav,38)=dphete
      ! 15/12/09        dav1(idav,39)=dphase*180./pi
      ! 15/12/09        else
      dav1(idav, 38) = dphete
      ! 15/12/09        endif
      ! end print in the file: 'short.data'
      write (16, 3777)
3777  format (/, 3x, 3('*'), ' DYNAMICS AT THE OUTPUT: ', /, 5x, '   BETA     dW(MeV)    ENERGY(MeV) ', &
        '   TOF(deg)     TOF(sec)')
      write (16, 3473) bets, delwrm, enrs - xmat, fh*trefs*180./pi, trefs
3473  format (' REF ', f7.5, 3x, f10.6, 3x, f8.3, 3x, e12.5, 3x, e12.5)
      write (16, 1789) bcog, encog - enold, encog - xmat, tcog*fh*180./pi, tcog
1789  format (' COG ', f7.5, 3x, f10.6, 3x, f8.3, 3x, e12.5, 3x, e12.5)
      ! trace3d
      ! split cell into drif-gap-drift
      kt3t = kt3t + 1
      write (tif, 6001) kt3t, kt3t, 10.*etcell(4)/2.
6001  format ('  nt(', i4, ')= 1, a(1,', i4, ')=', f12.6)
      trace3t(kt3t) = tif

      trphase = etcell(12)
      ! tre0tl=etcell(11)*etcell(5)*etcell(4)/100.
      tre0tl = delwrm/cos(pi*trphase/180.)
      kt3t = kt3t + 1
      write (tif, 6005) kt3t, kt3t, tre0tl, trphase, fid
6005  format ('  nt(', i4, ')=10, a(1,', i4, ')=', f9.5, ' , ', f9.2, ', 1., 1.,', f5.3, ',')
      trace3t(kt3t) = tif

      kt3t = kt3t + 1
      write (tif, 6001) kt3t, kt3t, 10.*etcell(4)/2.
      trace3t(kt3t) = tif
      ! end trace3d drift-gap-drift
      testca = exten(1)*exten(2)*exten(3)
      epsil = 1.e-40
      if (abs(testca)>epsil) then
        qdisp = 2.*sqrt(exten(1))
        qmd = exten(1)*exten(3) - exten(2)**2
        sqmdv = 4.*pi*sqrt(qmd)
        surm = 4.*pi*sqrt(qmd)*180./pi
        qdp = 2.*sqrt(exten(3))
        cor12 = exten(2)/sqrt(exten(1)*exten(3))
        qdpde = qdp*180./pi
      else
        qdisp = 0.
        qmd = 0.
        sqmdv = 0.
        surm = 0.
        qdp = 0.
        cor12 = 0.
        pent12 = 0.
        pent21 = 0.
        qdpde = 0.
      end if
      trqtx = exten(4)*exten(5) - exten(8)**2
      trqpy = exten(6)*exten(7) - exten(9)**2
      qditax = 2.*sqrt(exten(4))
      qdiant = 2.*sqrt(exten(5))
      qditay = 2.*sqrt(exten(6))
      qdianp = 2.*sqrt(exten(7))
      surxth = 4.*pi*sqrt(trqtx)
      suryph = 4.*pi*sqrt(trqpy)
      if (shift) then
        vref = bets*vl
        tref = trefs
      else
        vref = bcog*vl
        tref = tcog
      end if
      if (itvol) then
        ttvols = tref
        ! 15/12/09        attvol=fh*ttvols*180./pi
        ! 15/12/09        write(16,7456) ottvol,attvol
      end if
      ! 15/12/09 7456   format(2x,'***tof at input: ',e12.5,' deg',/,
      ! 15/12/09     *           2x,'***tof at output: ',e12.5,' deg')
      call statis
      ! PROFIL (plot)
      call stapl(dav1(idav,24))
      dltaw = qdisp*xmat*bcog*bcog/sqrt(1.-bcog*bcog)
      ! sup       WRITE(16,9998) SQMDV
      ! sup9998   FORMAT(2X,'   EMITTANCE (norm): ',
      ! sup     *        E12.5,' PI*MEV*RAD')
      ! print in the file: 'dynac.dmp':
      ! gap number, phase offset(deg), relativistic beta, energy(MeV), horz. emit.(mm*mrd,norm), vert.
      ! emit.(mm*mrd,norm),long. emit(keV*sec)
      ! dav1(idav,16): Emittance(norm)  x-xp (mm*mrad)
      dav1(idav, 16) = bcog*surxth*10./(pi*sqrt(1.-bcog*bcog))
      ! dav1(idav,21): Emittance(norm)  y-yp (mm*mrad)
      dav1(idav, 21) = bcog*suryph*10./(pi*sqrt(1.-bcog*bcog))
      dav1(idav, 25) = ndtl
      emns = 1.e12*sqmdv/(pi*fh)
      ! et2010s
      trfprt = fh*tref*180./pi
      tcgprt = fh*tcog*180./pi
      ! n2kp=int(tofprt/360.)
      ! tofprt=tofprt-float(n2kp)*360.
      ! if(tofprt.gt.180.) tofprt=tofprt-360.
      ! cavity number, z(m), transmission (%), synchronous phase (deg), time of flight (deg) (cog), COG relativistic
      ! beta (@ output)
      ! COG output energy (MeV), time of flight (deg) (REF), REF relativistic beta (@ output), REF output energy (MeV),
      ! horizontal emittance (mm.mrad, RMS normalized), vertical emittance (mm.mrad, RMS normalized),
      ! longitudinal emittance (RMS, ns.keV)
      trnsms = 100.*float(ngood)/float(imax)
      if (ndtl==1) write (50, *) '# gap.dmp'
      if (ndtl==1) write (50, *) '# gap     Z       trans   ', &
        'PHIs     TOF(COG)    COG        Wcog          TOF(REF)   ', &
        '    REF        Wref       Ex,RMS,n     Ey,RMS,n     El,RMS'
      if (ndtl==1) write (50, *) '#  #     (m)       (%)    ', &
        '(deg)     (deg)      beta       (MeV)          (deg)      ', &
        '   beta       (MeV)      (mm.mrad)    (mm.mrad)    (ns.keV)'
      write (50, 7023) ndtl, 0.01*davtot, trnsms, dphete, tcgprt, bcog, encog - xmat, trfprt, bets, enrs - xmat, &
        0.25*dav1(idav, 16), 0.25*dav1(idav, 21), 0.25*emns
7023  format (1x, i4, 1x, e12.5, 1x, f6.2, 1x, f7.2, 1x, 2(e14.7,1x,f7.5,1x,e14.7,1x), 3(e12.5,1x))
      ! et2010e
      ! RIGIDITY of the ref. prtcle
      gref = 1./sqrt(1.-bets*bets)
      xmor = xmat*bets*gref
      boro = 33.356*xmor*1.e-01/qst
      write (16, *) ilost, ' particles are lost in element ', ndtl
      write (16, *)
      call emiprt(0)
      return
    end subroutine etgap
    ! *******************************************************************
    ! SUBROUTINE gap(GAMREF,SAPHI,GAMS,DELPHR)
    ! ETGAP or RESTAY ==> GAP
    ! dynamics in the accelerating element
    ! *******************************************************************
    subroutine gap(gamref, saphi, gams, delphr)
      implicit real *8(a-h, o-z)
      parameter(iptsz=100002, maxcell=3000, maxcell1=3000)
      common /ttfs/dynt(maxcell), dyntp(maxcell), dyntpp(maxcell), dyne0(maxcell), dynph(maxcell), dynlg(maxcell), &
        fhpar, nc
      common /posi/ist
      common /midgap/enmil, vapmi
      common /azmtch/dlg, xmcph, xmce
      common /azlist/icont, iprin
      common /itvole/itvol, imamin
      common /func/a(200), ylg, atte, ncel, nharm
      ! TRANSIT TIME COEFFICIENTS
      common /ttfc/tk, t1k, t2k, sk, s1k, s2k, fh
      ! ***************************************************************
      common /bedycp/phslip, eqvl, asdl, peqvl, pavph, xkp1, xkp2, aa, bb, cc, dd, ee, pcrest, sqcttf
      common /jacob/gaks, gaps
      common /iter1/dxdki, dphii, phi, dkmske, dkmsphi, retph, xkmi, xkm, dxk00, tke, t1ke, ske, s1ke, phiwc, xk1i, &
        xk1ii, xk2ii
      ! functions in COS(DXDPT)
      common /iterco/yh11t, yh1k1t, yh1k01t, yh10pkt, yh11pkt, yh1p1t, h1akit, h1akimt, h1akmt, hapit, happit
      ! functions in SIN(DXDPT)
      common /itersi/yh21t, yh2k1t, yh2k01t, yh2p1t, yh20pkt, yh21pkt, h1bkit, h1bkimt, h1bkmt, hbpit, hbppit
      common /tranrs/sa11, sa12, sa21, sa22, sact11, sact12, sact21, sact22
      ! --- routine XTYPL1
      common /typl1/yh1k0, yh1k1, yp1k1, yp1k2, yh1k00, yh1k01, yp1k01, yp1k02, yh10, yh11, yp11, yp12
      common /typl2/yh2k0, yh2k1, yp2k1, yp2k2, yh2k00, yh2k01, yp2k01, yp2k02, yh20, yh21, yp21, yp22
      common /typi1/ye1k0, ye1k1, ye1k2, ye1kc0, ye1kc1, ye1kc2, ye10, ye11, ye12
      common /typi2/ye2k0, ye2k1, ye2k2, ye2kc0, ye2kc1, ye2kc2, ye20, ye21, ye22
      common /thad2/h0aki, h0akim, h0akm, h0bki, h0bkim, h0bkm, h1aki, h1akim, h1akm, h1bki, h1bkim, h1bkm
      ! --- routine XTYPLP1
      common /typlp1/yh1p1, yh2p1, hapi, hbpi
      ! --- routine XTYPL2
      common /typlp2/happi, hbppi
      ! --- routine XTYLPK
      common /typlpk/yh10pk, yh11pk, yh20pk, yh21pk
      ! Integrals of E(z)**2
      ! --- routine XTYPJ
      common /typj/yfsk0, yfsk1, yfsk2, yfsp0, yfsp1, yfsp2, yfskc0, yfskc1, yfskc2, yfsck0, yfsck1, yfsck2, yfscp0, &
        yfscp1, yfscp2, yfs0, yfs1, yfs2
      ! --- routine XTYPM
      common /typm/ynsk0, ynsk1, ynsk2, ynsp0, ynsp1, ynsp2, ynsk0c, ynsk1c, ynsk2c, yns0, yns1, yns2
      ! ********************************************************************
      common /faisc/f(10, iptsz), imax, ngood
      common /qmoyen/qmoy
      common /rigid/boro
      common /beamsa/fs(7, iptsz)
      common /cdek/dwp(iptsz)
      common /sc3/beamc, scdist, sce10, cplm, ect, apl, ichaes, iscsp
      common /consta/vl, pi, xmat, rpel, qst
      common /dyn/tref, vref
      common /tapes/in, ifile, meta
      common /etcom/cog(8), exten(17), fd(iptsz)
      common /speda/dave, idave
      common /shif/dtiph, shift
      common /davcom/dav1(maxcell1, 40), davtot, iitem(maxcell1), idav
      common /etcha1/dav2(maxcell1, 33), ichas(iptsz), chasit
      common /dcspa/iesp
      common /fene/wdisp, wphas, wx, wy, rlim, ifw
      common /appel/irstay, ilost, iavp, ispcel
      common /posc/xpsc
      common /pstpla/tstp
      common /rander/ialin
      common /cgtof/charm(20), cgtdv(20), nbch(20), netac
      logical iesp, ichaes, irstay, iavp, ispcel, ialin
      logical shift, chasit, itvol, imamin, dave
      ! *****      DWRFS(MeV):  gain of energy of the fictitious reference
      ! *****     SPHRFS(rad): phase jump
      ! *****      PHRFS(rad):  phase
      ! *****     NGDRF:  position of the reference in the array f(10,iptsz)
      ! ****       common/parmrf/DWRFS,SPHRFS,PHRFS,ngdrf
      ! CHARACTER*1 CHOPT
      fh0 = fh/vl
      ! iesp is used in s.c. routines : iesp=.false. == > accel. element
      iesp = .false.
      iavp = .true.
      ipas = 2
      dcum = ylg
      ! random errors in alignment
      if (ialin) call randali
      ! Random variation on the phase for each particle
      varpha = 0.
      ! INTEGRALS REQUIRED BY THE EXPANSIONS IN LONGITUDINAL MOTION (ALL THE ELEMENT)
      ! ( computations of the average k and slip of phase from which are computed deltk delphi,..)
      ! *   valero 08/08/07
      aqmoy = abs(qst)
      ! omment       aqmoy=qst
      ! *
      call xtypl1(gamref, saphi, aqmoy, dcum)
      ! see here equations 88 and 106 of Part. Acc. 1994 vol44 pp215-255
      cxlg = aqmoy/(4.*xmat*eqvl)
      gami = gamref
      dkmp = (gami*gami-1.)**(1.5)*(gams*gams-1.)**(-1.5)
      dkms = dkmp*(1.+asdl/eqvl) + yh1k01*fh0*cxlg/eqvl - asdl/eqvl
      dkm1 = -gaks*(gams*gams-1.)**(-1.5)*fh0*(1.+asdl/eqvl)
      ! DKMSKE :(eq.106, see article of Part.Acc.)
      dkmske = dkms/(1.-yh1k1*cxlg*fh0/eqvl-dkm1)
      call xtypl2(gamref, saphi, aqmoy, dcum)
      call xtyplp1(gamref, saphi, aqmoy, dcum)
      call xtylpk(gamref, saphi, aqmoy, dcum)
      dphsph1 = (yh1p1-yh21)*cxlg*fh0
      dkmsphi = -fh0*(gams*gams-1.)**(-1.5)*gaps*(1.+asdl/eqvl) + dphsph1/eqvl
      ! These integrals are saved
      gakst = gaks
      gapst = gaps
      ! functions in COS(DXDPT)
      yh11t = yh11
      yh1k1t = yh1k1
      yh1k01t = yh1k01
      yh10pkt = yh10pk
      yh11pkt = yh11pk
      yh1p1t = yh1p1
      h1akit = h1aki
      h1akimt = h1akim
      h1akmt = h1akm
      hapit = hapi
      happit = happi
      ! functions in SIN(DXDPT)
      yh21t = yh21
      yh2k1t = yh2k1
      yh2k01t = yh2k01
      yh2p1t = yh2p1
      yh20pkt = yh20pk
      yh21pkt = yh21pk
      h1bkit = h1bki
      h1bkimt = h1bkim
      h1bkmt = h1bkm
      hbpit = hbpi
      hbppit = hbppi
      if (ichaes .and. ispcel) then
        ipas = 1
        write (16, *) '  SPACE CHARGE ACTING ON LENGTH: ', scdist, ' CM'
        dcum = ylg*xpsc
        write (16, *) '  POSITION OF S.C. COMPUTATION:  ', dcum, ' CM'
        ! computation of the integrals in the middle of the cavity
        ! INTEGRALS  E(z)*(BG)**-3 *z**n   n=0,1
        ! INTEGRALS  dE(z)/dt*(BG)**-3 *z**n   n=0,1,2
        call xtypl1(gamref, saphi, aqmoy, dcum)
        istm = ist - 1
        ! INTEGRALS ON SECOND DERIVATIVES k HA0(Z) & HB0(Z)
        call xtypl2(gamref, saphi, aqmoy, dcum)
        ! 1st,2nd,3rd DERIVATIVES ON PHASE,HA0(Z) & HB0(Z)
        call xtyplp1(gamref, saphi, aqmoy, dcum)
        ! DERIVATIVES  COUPLED ON PHASE, K FUNCTIONS HA0(Z) & HB0(Z)
        call xtylpk(gamref, saphi, aqmoy, dcum)
        ! TRANSVERSE INTEGRALS  TYPE J & M
        call xtypj(gamref, saphi, aqmoy, dcum)
        call xtypm(gamref, saphi, aqmoy, dcum)
      end if
1026  continue
      if (ipas==2) then
        dcum = ylg
        gaks = gakst
        gaps = gapst
        ! --- COS(DXDPT)
        yh11 = yh11t
        yh1k1 = yh1k1t
        yh1k01 = yh1k01t
        yh10pk = yh10pkt
        yh11pk = yh11pkt
        yh1p1 = yh1p1t
        h1aki = h1akit
        h1akim = h1akimt
        h1akm = h1akmt
        hapi = hapit
        happi = happit
        ! ---  SIN(DXDPT)
        yh21 = yh21t
        yh2k1 = yh2k1t
        yh2k01 = yh2k01t
        yh2p1 = yh2p1t
        yh20pk = yh20pkt
        yh21pk = yh21pkt
        h1bki = h1bkit
        h1bkim = h1bkimt
        h1bkm = h1bkmt
        hbpi = hbpit
        hbppi = hbppit
        call xtypl1(gamref, saphi, aqmoy, dcum)
        ! INTEGRALS ON SECOND DERIVATIVES k HA0(Z) & HB0(Z)
        call xtypl2(gamref, saphi, aqmoy, dcum)
        ! 1st,2nd,3rd DERIVATIVES ON PHASE,HA0(Z) & HB0(Z)
        call xtyplp1(gamref, saphi, aqmoy, dcum)
        ! DERIVATIVES  COUPLED ON PHASE, K FUNCTIONS HA0(Z) & HB0(Z)
        call xtylpk(gamref, saphi, aqmoy, dcum)
        ! TRANSVERSE INTEGRALS  TYPE J & M
        call xtypj(gamref, saphi, aqmoy, dcum)
        call xtypm(gamref, saphi, aqmoy, dcum)
      end if
      sa11 = 1.
      sa12 = 0.
      sa21 = 0.
      sa22 = 1.
      sact11 = 1.
      sact12 = 0.
      sact21 = 0.
      sact22 = 1.
      ! SAVE BEAM
      do is = 1, ngood
        do js = 1, 7
          fs(js, is) = f(js, is)
        end do
      end do
      ! 1055   CONTINUE
      call boucle(ipas, gamref, saphi, dcum, delphr)
      ! Reshuffles f(i,j) array after boucle
      call shuffle
      if (ipas==1) then
        ! compute the space charge on the beam (except the reference)
        ! call stapl at the position of space charge computation
        ! *et*26-Jul-2014         call stapl(tstp)
        if (iscsp==1) then
          ini = 1
          call hersc(ini)
          ini = 2
          call hersc(ini)
        end if
        if (iscsp==2) call schermi
        if (iscsp==3) call scheff1(1)
        ! -----  window control
        write (16, *) 'Checking for lost particles'
        call reject(ilost)
        ! Reshuffles f(i,j) array after window (now done in 'reject')
        ! call shuffle
        ! second step of the gap
        ipas = 2
        iavp = .false.
        go to 1026
        ! end of space charge computation
      end if
      ! charateristics of the beam
      ! 18/03/2009       if (dave) then
      ! 18/03/2009         gimax=f(7,ngood)/xmat
      ! 18/03/2009         bimax=sqrt(1.-1./(gimax*gimax))
      ! 18/03/2009         dav1(idav,3)=bimax
      ! 18/03/2009         dav1(idav,4)=f(7,ngood)-xmat
      ! 18/03/2009         dav1(idav,5)=-(INT(f(6,ngood)*FH/PI+0.5)-
      ! 18/03/2009     *                f(6,ngood)*FH/PI)*180.
      ! 18/03/2009         dav1(idav,38)=dphase*180./pi
      ! 18/03/2009       endif
      ! ----       WINDOW CONTROL
      call reject(ilost)
      ! Reshuffles f(i,j) array after window (now done in 'reject')
      ! call shuffle
      return
    end subroutine gap
    ! *******************************************************************
    ! SUBROUTINE cogetc
    ! COG of TOF with respect to the various charge states
    ! *******************************************************************
    subroutine cogetc
      implicit real *8(a-h, o-z)
      parameter(iptsz=100002, maxcell=3000, maxcell1=3000)
      common /faisc/f(10, iptsz), imax, ngood
      common /cgtof/charm(20), cgtdv(20), nbch(20), netac

      itot = 0
      n = 1
      do i = 1, 20
        nbch(i) = 0
      end do
      charm(n) = f(9, 1)
100   continue
      do i = 1, ngood
        if (f(9,i)==charm(n)) nbch(n) = nbch(n) + 1
      end do
      ! the following charge states
      itot = itot + nbch(n)
      if (itot>=ngood) go to 110
      do i = 1, ngood
        do j = 1, n
          if (f(9,i)==charm(j)) go to 120
        end do
        if (f(9,i)/=charm(n)) then
          n = n + 1
          charm(n) = f(9, i)
          go to 100
        end if
120     continue
      end do
110   continue
      ! compute the cog of TOF for each charge state
      do i = 1, n
        cgtdv(i) = 0.
        do j = 1, ngood
          if (f(9,j)==charm(i)) cgtdv(i) = cgtdv(i) + f(6, j)
        end do
        cgtdv(i) = cgtdv(i)/float(nbch(i))
        ! write(16,*)'i,nch,cgtdv=',i,nbch(i),cgtdv(i),charm(i)
      end do
      netac = n
      return
    end subroutine cogetc
    ! *******************************************************************
    ! SUBROUTINE boucle(ipas,gamref,saphi,dcum,delphr)
    ! RESTAY or ETGAP ==> GAP ==> BOUCLE
    ! compute the dynamics of the fictitiuos reference and of particles
    ! *******************************************************************
    subroutine boucle(ipas, gamref, saphi, dcum, delphr)
      implicit real *8(a-h, o-z)
      parameter(iptsz=100002, maxcell=3000, maxcell1=3000)
      common /posi/ist
      common /midgap/enmil, vapmi
      common /azmtch/dlg, xmcph, xmce
      common /azlist/icont, iprin
      common /itvole/itvol, imamin
      common /iter1/dxdki, dphii, phi, dkmske, dkmsphi, retph, xkmi, xkm, dxk00, tke, t1ke, ske, s1ke, phiwc, xk1i, &
        xk1ii, xk2ii
      common /tranrs/sa11, sa12, sa21, sa22, sact11, sact12, sact21, sact22
      common /func/a(200), ylg, atte, ncel, nharm
      common /blvl/bflvl
      ! TRANSIT TIME COEFFICIENTS
      common /ttfc/tk, t1k, t2k, sk, s1k, s2k, fh
      common /ttfcb/t3k, t4k, s3k, s4k
      common /bedycp/phslip, eqvl, asdl, peqvl, pavph, xkp1, xkp2, aa, bb, cc, dd, ee, pcrest, sqcttf
      common /jacob/gaks, gaps
      common /typl1/yh1k0, yh1k1, yp1k1, yp1k2, yh1k00, yh1k01, yp1k01, yp1k02, yh10, yh11, yp11, yp12
      common /typl2/yh2k0, yh2k1, yp2k1, yp2k2, yh2k00, yh2k01, yp2k01, yp2k02, yh20, yh21, yp21, yp22
      common /typi1/ye1k0, ye1k1, ye1k2, ye1kc0, ye1kc1, ye1kc2, ye10, ye11, ye12
      common /typi2/ye2k0, ye2k1, ye2k2, ye2kc0, ye2kc1, ye2kc2, ye20, ye21, ye22
      common /thad2/h0aki, h0akim, h0akm, h0bki, h0bkim, h0bkm, h1aki, h1akim, h1akm, h1bki, h1bkim, h1bkm
      ! --- routine XTYPLP1
      common /typlp1/yh1p1, yh2p1, hapi, hbpi
      ! --- routine XTYPL2
      common /typlp2/happi, hbppi
      ! --- routine XTYLPK
      common /typlpk/yh10pk, yh11pk, yh20pk, yh21pk
      ! integrals of E(z)**2
      ! --- routine XTYPJ
      common /typj/yfsk0, yfsk1, yfsk2, yfsp0, yfsp1, yfsp2, yfskc0, yfskc1, yfskc2, yfsck0, yfsck1, yfsck2, yfscp0, &
        yfscp1, yfscp2, yfs0, yfs1, yfs2
      ! E(z)**2 INTEGRALS (COMPLEMENTARY ELECTRIC FIELD)
      ! --- routine XTYPM
      common /typm/ynsk0, ynsk1, ynsk2, ynsp0, ynsp1, ynsp2, ynsk0c, ynsk1c, ynsk2c, yns0, yns1, yns2
      common /faisc/f(10, iptsz), imax, ngood
      common /beamsa/fs(7, iptsz)
      common /cdek/dwp(iptsz)
      common /sc3/beamc, scdist, sce10, cplm, ect, apl, ichaes, iscsp
      common /consta/vl, pi, xmat, rpel, qst
      common /dyn/tref, vref
      common /fene/wdisp, wphas, wx, wy, rlim, ifw
      common /tapes/in, ifile, meta
      common /dcspa/iesp
      common /tcav/sv1p(iptsz), sv2p(iptsz), sxv1p(iptsz), sxv2p(iptsz), dwcis(iptsz), beini1(iptsz), phip(iptsz), &
        teglp(iptsz), dxdpip(iptsz), dxdkip(iptsz), dxdptp(iptsz), dxk00p(iptsz), dphiip(iptsz), sauphcs(iptsz)
      common /iterco/yh11t, yh1k1t, yh1k01t, yh10pkt, yh11pkt, yh1p1t, h1akit, h1akimt, h1akmt, hapit, happit
      common /itersi/yh21t, yh2k1t, yh2k01t, yh2p1t, yh20pkt, yh21pkt, h1bkit, h1bkimt, h1bkmt, hbpit, hbppit
      common /appel/irstay, ilost, iavp, ispcel
      common /etcom/cog(8), exten(17), fd(iptsz)
      common /cgtof/charm(20), cgtdv(20), nbch(20), netac
      common /tofev/ttvols
      common /aerp/vphase, vfield, ierpf
      ! *****     DWRFS(MeV): gain of energy of the fictitious reference
      ! *****     SPHRFS(rad):phase jump
      ! *****     PHRFS(rad):phase
      ! *****     NGDRF:  position of the reference in the array f(10,iptsz)
      ! *****       common/parmrf/DWRFS,SPHRFS,PHRFS,ngdrf
      logical itvol, imamin, ispcel
      logical iesp, iavp, ichaes, irstay
      dimension vecx(1)
      ! CHARACTER*1 CHOPT
      ttvol = ttvols*fh
      fh0 = fh/vl
      beref = sqrt(1.-1./(gamref*gamref))
      call cogetc
      tcog = 0.
      gcog = 0.
      do i = 1, ngood
        gcog = gcog + f(7, i)/xmat
        tcog = tcog + f(6, i)
      end do
      tcog = tcog/float(ngood)
      gcog = gcog/float(ngood)
      bcog = sqrt(1.-1./(gcog*gcog))
      wcg = (gcog-1.)*xmat
      ! ----- convert wdisp in dp/p (window control)
      ! ---- ifw = 0 ===> wdisp = dW/W
      ! ---- ifw = 1 ===> wdisp = dW (MeV)
      ! ----- convert wdisp in dp/p
      if (ifw==0) dispr = gcog*gcog*wdisp/(gcog*(gcog+1.))
      if (ifw==1) dispr = gcog*gcog*wdisp/(gcog*(gcog+1.)*wcg)
      do i = 1, ngood
        if (i==icont) then
          write (16, *) '******************************************'
          write (16, *) '*** FOLLOWED PARTICLE NUMBER: ', i
          if (ipas==1) write (16, *) ' AT SPACE CHARGE POSITION'
          if (ipas==2) write (16, *) ' AT OUTPUT '
          write (16, *) '******************************************'
        end if
        if (iavp) then
          gini = f(7, i)/xmat
          beini = sqrt(1.-1./(gini*gini))
          fd(i) = (gini*beini)/(gcog*bcog)
          f6i = 0.
          do istc = 1, netac
            if (f(9,i)==charm(istc)) f6i = f(6, i) - cgtdv(istc)
          end do
          ! LONGITUDINAL WINDOW CONTROL
          if (fh*abs(f6i)>=wphas) f(8, i) = 0.
          if (abs(fd(i)-1.)>=dispr) f(8, i) = 0.
          ! TRANSVERSE WINDOW CONTROL
          radiu = sqrt(f(2,i)*f(2,i)+f(4,i)*f(4,i))
          if (radiu>=rlim) f(8, i) = 0.
          if (abs(f(2,i))>wx) f(8, i) = 0.
          if (abs(f(4,i))>wy) f(8, i) = 0.
          if (f(8,i)==0) then
            write (16, 3928) i, int(f(1,i)), f(2, i), f(3, i), f(4, i), f(5, i), f6i*fh*180./pi, f(7, i) - xmat, &
              int(f(9,i))
3928        format (' # ', i5, 1x, i5, 1x, 6(f10.2,1x), 1x, i2)
            ilost = ilost + 1
            if (ilost>=ngood) stop
            go to 19
          end if
          ! COMPUTATION OF AVERAGE K AND JUMP OF PHASE FOR THE CELL
          ! START IF BLOCK on ICONT
          if (i==icont) then
            write (16, 558) f(2, i), f(3, i), f(4, i), f(5, i)
558         format (1x, '* INPUT OF THE ELEMENT: ', /, 1x, '* X :', e12.5, ' CM  XP :', e12.5, ' MRD', /, 1x, '* Y :', &
              e12.5, ' CM  YP: ', e12.5, ' MRD', /, 1x, '*')
            f6dg = fh*f(6, i)*180./pi
            write (16, *) ' Tof(deg): ', f6dg, ' ENER(MeV) ', f(7, i) - xmat
          end if
          radiu = sqrt(f(2,i)*f(2,i)+f(4,i)*f(4,i))
          if (radiu<1.e-06) then
            dradiu = .001*sqrt(f(3,i)*f(3,i)+f(5,i)*f(5,i))
          else
            dradiu = f(3, i)*.001*f(2, i)/radiu + f(4, i)*f(5, i)*.001/radiu
          end if
          ! 335        CONTINUE
          ! --- retph: phase delay between the actual particle  and the reference
          retph = fh*(f(6,i)-tref)
          ! --- systematic or random defaults on the phase RF (not for the reference)
          if (ierpf/=0) then
            vphasi = vphase*pi/180.
            ! --- systematic default on the phase offset
            if (ierpf==1) retph = retph + vphasi
            ! --- random error on  phase offset
            if (ierpf>1) then
              len = 1
              call rlux(vecx, len)
              r1 = (2.*vecx(1)-1.)*vphasi
              retph = retph + r1
            end if
          end if
          phi = saphi + retph
          if (i==icont) write (16, *) '* PHASE DELAY RELATIVE TO REFERENCE ', retph*180./pi, ' DEG'
          ! --- the TTF are the ones of the reference particle based on the charge state qst (input)
          ! ---  They are corrected in order to take into account the charge state of the current particle
          ! ****       cort=-(1.-(qst/f(9,i)))
          cort = 0.
          tkc = tk*cort + tk
          t1kc = t1k*cort + t1k
          t2kc = t2k*cort + t2k
          t3kc = t3k*cort + t3k
          t4kc = t4k*cort + t4k
          skc = sk*cort + sk
          s1kc = s1k*cort + s1k
          s2kc = s2k*cort + s2k
          s3kc = s3k*cort + s3k
          s4kc = s4k*cort + s4k
          ! cort1=qst/f(9,i)
          cort1 = 1.
          ! ************************************
          ! Predictor
          phase = phi
          ! DXKI0 : difference of energy betwen the reference and the actual particle
          dxki0 = fh0*(1./beini-1./beref)
          dxdte = dxki0
          tke = tkc + dxdte*t1kc + dxdte*dxdte*t2kc/2. + dxdte**3*t3kc/6. + dxdte**4*t4kc/24.
          ske = skc + dxdte*s1kc + dxdte*dxdte*s2kc/2. + dxdte**3*s3kc/6. + dxdte**4*s4kc/24.
          ! TEST*******
          ! cc           TKE=TKC
          ! cc           SKE=SKC
          ! ******************************************
          ! --- systematic or random defaults on the field level (not for the reference)
          if (ierpf/=0) then
            if (ierpf==1) then
              tke = tke*(1.+vfield)
              ske = ske*(1.+vfield)
            end if
            if (ierpf>1) then
              len = 1
              call rlux(vecx, len)
              r1 = (2.*vecx(1)-1.)*vfield
              tke = tke*(1.+r1)
              ske = ske*(1.+r1)
            end if
          end if
          phiwc = phi + pavph
          ! TEST***********
          ! ccc           PHIWC=PHI
          ! *****************************************************
          ddwp = abs(f(9,i))*(tke*cos(phiwc)-ske*sin(phiwc))
          enpmt = f(7, i) + ddwp
          gamps = enpmt/xmat
          if (gamps<=1.) f(8, i) = 0.
          if (f(8,i)==0.) then
            ilost = ilost + 1
            if (ilost>=ngood) stop
            go to 19
          end if
          betps = sqrt(1.-1./(gamps*gamps))
          xk1ii = fh0/beini
          xk2ii = fh0/betps
          xkmi = xk2ii + (xk2ii-xk1ii)*asdl/eqvl + delphr/eqvl
          xk1i = xk1ii - xkmi
          xk2i = xk2ii - xkmi
          bempy = fh0/xkmi
          sauphc = delphr
          dxdki = xkmi - xkm
          dphii = (xk1ii-xk2ii)*eqvl/10. + (xkp1+xkp2)/120.*eqvl**2 + xk1i*asdl
          do ijk = 1, 3
            ! --- boucle IJK to improve  TTF
            tke = tkc + dxdki*t1kc + dxdki*dxdki*t2kc/2. + dxdki**3*t3kc/6. + dxdki**4*t4kc/24.
            t1ke = t1kc + dxdki*t2kc + dxdki*dxdki*t3kc/2. + dxdki**3*t4kc/6.
            ske = skc + dxdki*s1kc + dxdki*dxdki*s2kc/2. + dxdki**3*s3kc/6. + dxdki**4*s4kc/24.
            s1ke = s1kc + dxdki*s2kc + dxdki*dxdki*s3kc/2. + dxdki**3*s4kc/6.
            ! TEST*********
            ! cc             TKE=TKC
            ! cc             T1KE=T1KC
            ! cc             SKE=SKC
            ! cc             S1KE=S1KC
            ! **********************************************************
            ! --- systematic or random defaults on the field level (not for the reference)
            if (ierpf==1) then
              tke = tke*(1.+vfield)
              ske = ske*(1.+vfield)
              t1ke = t1ke*(1.+vfield)
              s1ke = s1ke*(1.+vfield)
            end if
            if (ierpf>1) then
              len = 1
              call rlux(vecx, len)
              r1 = (2.*vecx(1)-1.)*vfield
              tke = tke*(1.+r1)
              ske = ske*(1.+r1)
              t1ke = t1ke*(1.+r1)
              s1ke = s1ke*(1.+r1)
            end if
            pcresi = 0.
            dphci0 = 0.
            ! if(f(9,i).ne.qst) then
            ! --- new crest phase is PCRESI
            ! cc              PCRESI=ATAN(-SKE/TKE)
            ! cc              DDWC=abs(f(9,i))*(TKE*COS(PCRESI)-SKE*SIN(PCRESI))
            ! cc              IF(DDWC.LT.0.) PCRESI=PCRESI+PI
            ! --- DPHCI0 is the difference between the previous crest phase and the present one
            ! cc              DPHCI0=PCREST-PCRESI
            ! endif
            ! **************************************
            ! cc             PHIWC=PHI+DPHII-DPHCI0
            ! TEST********
            phiwc = phi + dphii
            ! ***********************************
            ! ****             PHIWC=PHI+DPHII
            dwci = abs(f(9,i))*(tke*cos(phiwc)-ske*sin(phiwc))
            enrc = f(7, i) + dwci
            gacr = enrc/xmat
            becr = sqrt(1.-1./(gacr*gacr))
            xk2ii = fh0/becr
            cxlg = abs(f(9,i))/(4.*xmat*eqvl)
            dxdpi = retph - dphci0
            ! --- see Part. Acc., 1994, vol 44., pp. 215-255
            ! ----     relation 86
            dxdpt = dxdpi + dxk00*(1.-dkmske)*asdl - dxdpi*dkmsphi*asdl
            dxk00 = fh0*(1./beini-1./beref)
            xlh11 = (yh11t+dxk00*(dkmske*yh1k1t+yh1k01t))*cos(dxdpt)
            xlh11 = xlh11 + dxdpi*yh1p1t*cos(dxdpt)
            ! second derivative of Ha0(Z) (division by 2 has been made)
            xlh112 = dxk00*dxk00*(h1akit+h1akimt*dkmske+h1akmt*dkmske*dkmske)*cos(dxdpt)
            xlh112 = xlh112 + dxdpi*dxdpi*hapit*cos(dxdpt)
            xlh112 = xlh112 + dxdpi*dxk00*(yh10pkt+dkmske*yh11pkt)*cos(dxdpt)
            ! third derivative of Ha0(Z)
            xlh113 = (dxdpi**3)/3.*happit*cos(dxdpt)
            xlh11 = xlh11 + xlh112 + xlh113
            ! first derivative of Hb0(Z)
            xlh21 = (yh21t+dxk00*(dkmske*yh2k1t+yh2k01t))*sin(dxdpt)
            xlh21 = xlh21 + dxdpi*yh2p1t*sin(dxdpt)
            ! second derivative of Hb0(Z) (division by 2 has been made)
            xlh212 = dxk00*dxk00*(h1bkit+h1bkimt*dkmske+h1bkmt*dkmske**2)*sin(dxdpt)
            xlh212 = xlh212 + dxdpi*dxdpi*hbpit*sin(dxdpt)
            xlh212 = xlh212 + dxdpi*dxk00*(yh20pkt+dkmske*yh21pkt)*sin(dxdpt)
            ! third derivative of of Hb0(Z)
            xlh213 = (dxdpi**3)/3.*hbppit*sin(dxdpt)
            xlh21 = xlh21 + xlh212 + xlh213
            xlh1i = cxlg*(xlh11-xlh21)
            ! --- SAUPHC is the jump of phase
            sauphc = fh0*xlh1i
            ! ---     XKMI:  AVERAGE factor k (k = frequency/velovity)
            xkmi = xk2ii + sauphc/eqvl + (xk2ii-xk1ii)*asdl/eqvl
            bempy = fh0/xkmi
            xk1i = xk1ii - xkmi
            dxdki = xkmi - xkm
            dphii = (xk1ii-xk2ii)*eqvl/10. + (xkp1+xkp2)/120.*eqvl**2 + xk1i*asdl
          end do
          ! TEST****       ENDDO IJK=1,3
          ! Compute the shift of phase: PHSLIL
          dts = (tke*t1ke+ske*s1ke)/(tke*tke+ske*ske)
          tiltal = -4.*atan(dts*3.2/eqvl)
          if (tiltal/=0.) then
            til2 = tiltal/2.
            xlrei = eqvl
            do iiii = 1, 4
              ftil = 1./tan(til2) - 1./til2 - dts*2./xlrei
              dftil = -1./(sin(til2)*sin(til2)) + 1./(til2*til2)
              if (dftil/=6.*0.) then
                til2 = til2 - ftil/dftil
                gx = 1./tan(til2) - 1./til2
                xlrei = 2.*dts/gx
              end if
            end do
            tiltal = til2*2.
          end if
          phslil = tiltal
          tegl1 = phslil*phslil/(sin(phslil/2.)*sin(phslil/2.))
          tegl2 = (tke*tke+ske*ske)
          tegl = tegl1*tegl2/(eqvl*32.)
          tegl = tegl/eqvl
          ! ---   Transverse motion  (field E(z)**2)
          phitti = phiwc + xk1i*asdl - phslip/2.
          phitsi = phiwc + xk2i*asdl + phslip/2.
          cetf1 = f(9, i)*f(9, i)/(16.*xmat*xmat*eqvl*eqvl)
          ! TESTsv ***************************
          ! OLD****           CETF1=CETF1*cort1*cort1
          ! **************************
          cfv1 = (gini*gini+2.)/((gini*gini-1.)**2)
          cfv2 = (gacr*gacr+2.)/((gacr*gacr-1.)**2)
          sv1 = cfv1*(tke*cos(phitti)-ske*sin(phitti))**2
          sv1 = cetf1*sv1*(phslil/sin(phslil/2.))**2
          sv2 = cfv2*(tke*cos(phitsi)-ske*sin(phitsi))**2
          sv2 = cetf1*sv2*(phslil/sin(phslil/2.))**2
          ! Transverse motion  (field dE(z)/dt)
          ceti = fh0*abs(f(9,i))/(4.*xmat*eqvl)
          ! TESTsv ***************************
          ! OLD****           CETI=CETI*cort1
          ! **************************
          cxv1 = (gini*gini-1.)**1.5
          cxv2 = (gacr*gacr-1.)**1.5
          sxv1 = (tke*sin(phitti)+ske*cos(phitti))*phslil/sin(phslil/2.)
          sxv1 = -ceti*sxv1/cxv1
          sxv2 = (tke*sin(phitsi)+ske*cos(phitsi))*phslil/sin(phslil/2.)
          sxv2 = -ceti*sxv2/cxv2
          ! --- save all parameters
          sv1p(i) = sv1
          sv2p(i) = sv2
          sxv1p(i) = sxv1
          sxv2p(i) = sxv2
          dwcis(i) = dwci
          sauphcs(i) = sauphc
          beini1(i) = beini
          phip(i) = phi
          teglp(i) = tegl
          dxdpip(i) = dxdpi
          dxdkip(i) = dxdki
          dxdptp(i) = dxdpt
          dxk00p(i) = dxk00
          dphiip(i) = dphii
          ! END IF BLOCK  on APV
        end if
        ! --- ipas = 2: the dynamics is computed over all the element
        if (ipas==2) then
          ! Recover all previous parameters
          sauphc = sauphcs(i)
          xlh1i = sauphc/fh0
          dwci = dwcis(i)
          sv1 = sv1p(i)
          sv2 = sv2p(i)
          sxv1 = sxv1p(i)
          sxv2 = sxv2p(i)
          beini = beini1(i)
          gini = 1./sqrt(1.-beini*beini)
          phi = phip(i)
          tegl = teglp(i)
          dxdpi = dxdpip(i)
          dxdki = dxdkip(i)
          dxdpt = dxdptp(i)
          dxk00 = dxk00p(i)
          dphii = dphiip(i)
          go to 5678
        end if
        ! compute the jump of phase at position of space charge computation
        cxlg = abs(f(9,i))/(4.*xmat*eqvl)
        ! FUNCTION Ha0(Z)
        xlh11 = (yh11+dxk00*(dkmske*yh1k1+yh1k01))*cos(dxdpt)
        xlh11 = xlh11 + dxdpi*yh1p1*cos(dxdpt)
        ! SECOND DERIVATIVES OF Ha0(Z) (division by 2 has been made)
        xlh112 = dxk00*dxk00*(h1aki+h1akim*dkmske+h1akm*dkmske*dkmske)*cos(dxdpt)
        xlh112 = xlh112 + dxdpi*dxdpi*hapi*cos(dxdpt)
        xlh112 = xlh112 + dxdpi*dxk00*(yh10pk+dkmske*yh11pk)*cos(dxdpt)
        ! THIRD DERIVATIVE of Ha0(Z)
        xlh113 = (dxdpi**3)/3.*happi*cos(dxdpt)
        xlh11 = xlh11 + xlh112 + xlh113
        ! FUNCTION Hb0(Z)
        xlh21 = (yh21+dxk00*(dkmske*yh2k1+yh2k01))*sin(dxdpt)
        xlh21 = xlh21 + dxdpi*yh2p1*sin(dxdpt)
        ! SECOND DERIVATIVE OF Hb0(Z) (division by 2 has been made)
        xlh212 = dxk00*dxk00*(h1bki+h1bkim*dkmske+h1bkm*dkmske**2)*sin(dxdpt)
        xlh212 = xlh212 + dxdpi*dxdpi*hbpi*sin(dxdpt)
        xlh212 = xlh212 + dxdpi*dxk00*(yh20pk+dkmske*yh21pk)*sin(dxdpt)
        ! THIRD DERIVATIVE OF Hb0(Z)
        xlh213 = (dxdpi**3)/3.*hbppi*sin(dxdpt)
        xlh21 = xlh21 + xlh212 + xlh213
        xlh1i = cxlg*(xlh11-xlh21)
        sauphc = fh0*xlh1i
5678    continue
        cxlg = abs(f(9,i))/(4.*xmat*eqvl)
        xlh01 = (yh10+dxdki*yh1k0+dxk00*yh1k00)*cos(dxdpt)
        xlh02 = (yh20+dxdki*yh2k0+dxk00*yh2k00)*sin(dxdpt)
        xlh0i = cxlg*(xlh01-xlh02)
        ! -- COUPLING INTEGRALS
        xlp11 = (yp11+dxdki*yp1k1+dxk00*yp1k01)*cos(dxdpt)
        xlp21 = (yp21+dxdki*yp2k1+dxk00*yp2k01)*sin(dxdpt)
        xlp1i = cxlg*(xlp11-xlp21)
        xlp12 = (yp12+dxdki*yp1k2+dxk00*yp1k02)*cos(dxdpt)
        xlp22 = (yp22+dxdki*yp2k2+dxk00*yp2k02)*sin(dxdpt)
        xlp2i = cxlg*(xlp12-xlp22)
        radiu = sqrt(f(2,i)*f(2,i)+f(4,i)*f(4,i))
        if (radiu<1.e-06) then
          dradiu = .001*sqrt(f(3,i)*f(3,i)+f(5,i)*f(5,i))
        else
          dradiu = f(3, i)*.001*f(2, i)/radiu + f(4, i)*f(5, i)*.001/radiu
        end if
        rp = radiu
        rpp = dradiu
        ! Picht coordinates
        rrp = rp*sqrt(beini*gini)
        rrpp = rpp*sqrt(beini*gini)
        ! --- ipas = 1: the dynamics is computed until the position of space charge computation
        ! gain of energy at the position of space charge computation (not for the reference)
        if (ipas==1) then
          ! *****           PHIWC=PHI+DPHII-DPHCI0
          phiwc = phi + dphii
          ! istm: flag ==> the energy is compute at the position of space charge computation
          istm = ist - 1
          gacr = gamci(phiwc, pcresi, gini, istm, abs(f(9,i)))
          dwci = (gacr-gini)*xmat
        end if
        dwpi = dwci + xmat*fh0*fh0*rrp*rrp/4.*xlh0i + xmat*rrp*rrpp*fh0*fh0/2.*xlh1i
        ! PHASE JUMP
        delphi = sauphc + fh0**3*rrp*rrp/4.*xlp1i + fh0**3*rrp*rrpp/2.*xlp2i
        if (ipas==2) then
          ! kicks of energy from space charge effects are in dwp(i)
          if (ichaes) then
            f(7, i) = f(7, i) + dwpi + dwp(i)
            gamsor = f(7, i)/xmat
            if (gamsor<=1.) f(8, i) = 0.
            ! particle is lost
            if (f(8,i)==0.) go to 19
            besor = sqrt(1.-1./(gamsor*gamsor))
            ! phase jump resulting from space charge
            delgam = dwp(i)/xmat
            gamkk0 = f(7, i)/xmat
            bekk0 = sqrt(1.-1./(gamkk0*gamkk0))
            dbek21 = delgam/(bekk0**3*gamkk0**3)
            delsc = fh0*scdist*dbek21/2.
            delphi = delphi + delsc
            ditemp = ylg/(besor*vl) + delphi/fh
            f(6, i) = fs(6, i) + ditemp
          else
            f(7, i) = f(7, i) + dwpi
            gamsor = f(7, i)/xmat
            if (gamsor<=1.) f(8, i) = 0.
            ! particle is lost
            if (f(8,i)==0.) then
              f6i = f(6, i) - tcog
              write (16, 3928) i, int(f(1,i)), f(2, i), f(3, i), f(4, i), f(5, i), f6i*fh*180./pi, f(7, i) - xmat, &
                int(f(9,i))
              if (ilost>=ngood) stop
              ilost = ilost + 1
              go to 19
            end if
            besor = sqrt(1.-1./(gamsor*gamsor))
            ditemp = ylg/(besor*vl) + delphi/fh
            f(6, i) = f(6, i) + ditemp
          end if
        end if
        if (ipas==1) then
          f(7, i) = f(7, i) + dwpi
          gamsor = f(7, i)/xmat
          if (gamsor<=1.) f(8, i) = 0.
          if (f(8,i)==0.) then
            write (16, 3928) i, int(f(1,i)), f(2, i), f(3, i), f(4, i), f(5, i), f(6, i)*fh*180./pi, f(7, i) - xmat, &
              int(f(9,i))
            if (ilost>=ngood) stop
            ilost = ilost + 1
            go to 19
          end if
          besor = sqrt(1.-1./(gamsor*gamsor))
          ! TEST******
          ! DITEMP=YLG/(BESOR*VL)+DELPHI/FH
          ditemp = ylg/(2.*besor*vl) + delphi/fh
          ! 2014-Aug-08           DITEMP=ylg/(BESOR*VL)+DELPHI/FH
          ! cc             DITEMP=(2.*XK1II*ASDL+XKMI*(EQVL-ASDL)+
          ! cc     x              XK2II*(YLG-(EQVL+ASDL)))/FH+DELPHI/FH
          ! ****************************
          f(6, i) = f(6, i) + ditemp
        end if
        if (i==icont) then
          if (ipas==2) then
            write (16, *) '* DYNAMICS AT THE OUTPUT :'
            write (16, 994) delphi*180./pi, delsc*180./pi, dwp(i)
994         format (1x, '* PHASE JUMP ', e12.5, ' DEG  CORRECTED BY :', e12.5, ' DEG ', ' SC KICK(MEV) ', e12.5)
            enrprin = f(7, i) - xmat
            write (16, 88) dwpi, enrprin, besor, f(9, i), ditemp
88          format (1x, '* ENERGY GAIN : ', e14.7, ' MEV', '   ENERGY :', e14.7, ' MEV', /, 1x, '* BETA :', e12.5, /, &
              1x, '* CHARGE :', f5.0, ' TRANSIT TIME :', e12.5, ' SEC', /, 1x, '*')
            write (16, *) 'TK TKE ', tk, tke
            write (16, *) 'SK SKE ', sk, ske
            write (16, *) 'PCREST  PCRESI', pcrest, pcresi
          end if
          if (ipas==1) then
            write (16, *) '* DYNAMICS AT THE POSITION OF SPACE CHARGE :'
            enrprin = f(7, i) - xmat
            write (16, 9944) delphi*180./pi, dwpi, enrprin, ditemp
9944        format (1x, '* PHASE JUMP ', e12.5, ' DEG ', ' ENERGY GAIN : ', e14.7, ' MeV', ' ENERGY :', e14.7, ' MEV', &
              /, ' TRANSIT TIME :', e12.5, ' SEC', /, 1x, '*')
          end if
        end if
        amort = sqrt(beini*gini/(besor*gamsor))
        ! INTEGRALS OF THE TRANSVERSE MOTION (not computed for the reference)
        ! ******************
        ! ******       if(i.ne.ngdrf) then
        ! ----  integrals of E(Z)**2
        ! ----     (G**2+2/(G**2-1)**2)*E(z)**2
        cetf = f(9, i)*f(9, i)*sqcttf*sqcttf/(16.*xmat*xmat*eqvl*eqvl)
        ! TESTsv ********
        ! OLD****         CETF=CETF*cort1*cort1
        ! *************************************
        xjf0i = yfs0 + dxdki*(yfsk0+yfsck0) + dxdpi*(yfsp0+yfscp0) + dxk00*yfskc0
        xjf0i = xjf0i*cetf
        xjf1i = yfs1 + dxk00*dkmske*(yfsk1+yfsck1) + dxdpi*(yfsp1+yfscp1) + dxk00*yfskc1
        xjf1i = xjf1i*cetf
        xjf2i = yfs2 + dxk00*dkmske*(yfsk2+yfsck2) + dxdpi*(yfsp2+yfscp2) + dxk00*yfskc2
        xjf2i = xjf2i*cetf
        v1 = sv1
        v2 = sv2
        ! ----     (G**2+2/(G**2-1)**2)
        cetm = f(9, i)*f(9, i)*tegl/(xmat*xmat)
        ! TESTsv ********
        ! OLD****         CETM=CETM*cort1*cort1
        ! *************************************
        xmn0i = yns0 + dxdki*ynsk0 + dxdpi*ynsp0 + dxk00*ynsk0c
        xmn0i = xmn0i*cetm
        xmn1i = yns1 + dxk00*dkmske*ynsk1 + dxdpi*ynsp1 + dxk00*ynsk1c
        xmn1i = xmn1i*cetm
        xmn2i = yns2 + dxk00*dkmske*ynsk2 + dxdpi*ynsp2 + dxk00*ynsk2c
        xmn2i = xmn2i*cetm
        f0 = xjf0i + xmn0i
        f1 = xjf1i + xmn1i
        f2 = xjf2i + xmn2i
        ! ---     1/(B*G)**3 *dE(z)/dt
        ceti = fh0*abs(f(9,i))/(8.*xmat*eqvl)
        ! TESTsv ***************************
        ! OLD****         CETI=CETI*cort1
        ! **************************
        xie01 = (ye10+dxdki*ye1k0+dxk00*ye1kc0)*cos(dxdpt)
        xie02 = (ye20+dxdki*ye2k0+dxk00*ye2kc0)*sin(dxdpt)
        xie0i = -ceti*(xie01+xie02)
        xie11 = (ye11+dxdki*ye1k1+dxk00*ye1kc1)*cos(dxdpt)
        xie12 = (ye21+dxdki*ye2k1+dxk00*ye2kc1)*sin(dxdpt)
        xie1i = -ceti*(xie11+xie12)
        xie21 = (ye12+dxdki*ye1k2+dxk00*ye1kc2)*cos(dxdpt)
        xie22 = (ye22+dxdki*ye2k2+dxk00*ye2kc2)*sin(dxdpt)
        xie2i = -ceti*(xie21+xie22)
        xv1 = sxv1
        xv2 = sxv2
        xi0 = xie0i
        xi1 = xie1i
        xi2 = xie2i
        ! Transport matrix in 'PICHT' coordonates
        xq0 = xi0 - f0
        xq1 = xi1 - f1
        xq2 = xi2 - f2
        xq01 = (xq1+asdl*xq0)
        xq12 = (xq2+asdl*xq1)
        v1 = xv1 - v1
        v2 = xv2 - v2
        a11 = -xq01*(1.+(v1+v2)*eqvl*eqvl/120.)
        a12 = -(xq2+2.*asdl*xq1+asdl*asdl*xq0+eqvl*eqvl*((v1+v2)/120.+eqvl*v2/120.)*xq01)
        za = -(xq12/eqvl+v2*eqvl*eqvl*xq01/120.)
        zb = -((eqvl+asdl)*xq12/eqvl-eqvl*xq01/10.+v2*(eqvl+asdl)*eqvl*eqvl*xq01/120.)
        a21 = xq0*(1.+(v1+v2)*eqvl*eqvl/120.)
        a22 = xq1 + xq0*(asdl+asdl*eqvl*eqvl*(v1+v2)/120.+eqvl**3*v2/120.)
        zc = xq1/eqvl + v2*eqvl*eqvl*xq0/120.
        zd = (asdl+eqvl)*xq1/eqvl - (eqvl/10.+v2*(eqvl+asdl)*eqvl*eqvl/120.)*xq0

        tma = 1./(1.-za-zc*zb/(1.-zd))
        t11 = (a11+zb*a21/(1.-zd))*tma
        t12 = (a12+zb*a22/(1.-zd))*tma
        t21 = (a21+zc*t11)/(1.-zd)
        t22 = (a22+zc*t12)/(1.-zd)
        vr11 = (1.+t11+dcum*t21)
        vr12 = (t12+dcum*(1.+t22))
        vr21 = t21
        vr22 = 1. + t22
        if (i==icont) then
          detre = vr11*vr22 - vr12*vr21
          write (16, 8921) vr11, vr12, vr21, vr22, detre
8921      format (2x, ' TRANSVERSE CANONICAL MATRIX:(cm,radian) ', /, 2x, ' VR11:', e12.5, '   VR12:', e12.5, /, 2x, &
            ' VR21:', e12.5, '   VR22:', e12.5, /, 2x, ' DETERMINANT       :', e12.5, //)
        end if
        ! REAL MATRIX
        a11 = vr11*amort
        a12 = vr12*amort
        a21 = vr21*amort
        a22 = vr22*amort
        ! omment       ** cumulative matrix (particle 1)
        ! omment          tables R(,) ET T(,,,)
        ! omment         IF (I .EQ. 1.AND.IPAS.EQ.2) THEN
        ! omment           STA11=VR11*SA11+VR12*SA21
        ! omment           STA12=VR11*SA12+VR12*SA22
        ! omment           STA21=VR21*SA11+VR22*SA21
        ! omment           STA22=VR21*SA12+VR22*SA22
        ! omment           SA11=STA11
        ! omment           SA12=STA12
        ! omment           SA21=STA21
        ! omment           SA22=STA22
        ! omment           SAA11=SA11*AMORT
        ! omment           SAA12=SA12*AMORT
        ! omment           SAA21=SA21*AMORT
        ! omment           SAA22=SA22*AMORT
        ! omment           RS(1,1) =SAA11
        ! omment           RS(1,2) =SAA12
        ! omment           RS(2,1) =SAA21
        ! omment           RS(2,2) =SAA22
        ! omment           RS(3,3) =SAA11
        ! omment           RS(3,4) =SAA12
        ! omment           RS(4,3) =SAA21
        ! omment           RS(4,4) =SAA22
        ! omment           DO IA=1,6
        ! omment             DO IB=1,6
        ! omment               R(IA,IB)=RCUL(IA,IB)
        ! omment             ENDDO
        ! omment           ENDDO
        ! omment           CALL MFORDRE(RCUL,RS,R)
        ! omment         ENDIF
        ! BEAM COORDINATES
        fxt1 = a11*f(2, i) + a12*f(3, i)*1.e-03
        fxt2 = a21*f(2, i) + a22*f(3, i)*1.e-03
        fxt3 = a11*f(4, i) + a12*f(5, i)*1.e-03
        fxt4 = a21*f(4, i) + a22*f(5, i)*1.e-03
        f(2, i) = fxt1
        f(3, i) = fxt2*1.e03
        f(4, i) = fxt3
        f(5, i) = fxt4*1.e03
        if (i==icont) then
          ! ** CURRENT MATRIX
          stta11 = vr11*sact11 + vr12*sact21
          stta12 = vr11*sact12 + vr12*sact22
          stta21 = vr21*sact11 + vr22*sact21
          stta22 = vr21*sact12 + vr22*sact22
          sact11 = stta11
          sact12 = stta12
          sact21 = stta21
          sact22 = stta22
          saa11 = sact11*amort
          saa12 = sact12*amort
          saa21 = sact21*amort
          saa22 = sact22*amort
          det = a11*a22 - a12*a21
          write (16, 992) a11, a12*1.e-3, a21*1.e3, a22, det, amort
992       format (1x, '*  TRANSVERSE MATRIX (cm,mrd)', /, 1x, '*', e12.5, 3x, e12.5, /, 1x, '*', e12.5, 3x, e12.5, /, &
            1x, '* DETERMINANT :', e12.5, ' DUMPING OF ENERGY :', e12.5)
          write (16, *) '*'
          write (16, 559) f(2, i), f(3, i), f(4, i), f(5, i)
559       format (' * TRANVERSE COORDINATES AT OUTPUT  ', /, 1x, '* X :', e12.5, ' CM  XP :', e12.5, ' MRD ', /, 1x, &
            '* Y :', e12.5, ' CM  YP :', e12.5, ' MRD')
          if (ipas==2) write (16, *) '********** END OF FOLLOWED PARTICLE ********'
        end if
        ! *****        endif
19    end do
      return
    end subroutine boucle
    ! *******************************************************************
    ! SUBROUTINE bunparm(v,dp,harm,prlim)
    ! BUNCHER  (NO SPACE CHARGE EFFECT)
    ! *******************************************************************
    subroutine bunparm(v, dp, harm, prlim)
      implicit real *8(a-h, o-z)
      parameter(iptsz=100002, maxcell=3000, maxcell1=3000)
      common /rigid/boro
      common /consta/vl, pi, xmat, rpel, qst
      common /dyn/tref, vref
      common /davcom/dav1(maxcell1, 40), davtot, iitem(maxcell1), idav
      common /etcha1/dav2(maxcell1, 33), ichas(iptsz), chasit
      common /ttfc/tk, t1k, t2k, sk, s1k, s2k, fh
      common /faisc/f(10, iptsz), imax, ngood
      common /etcom/cog(8), exten(17), fd(iptsz)
      common /fene/wdisp, wphas, wx, wy, rlim, ifw
      common /corec/tref1
      common /qmoyen/qmoy
      common /aerp/vphase, vfield, ierpf
      common /itvole/itvol, imamin
      common /compt/nrres, nrtre, nrbunc, nrdbun
      common /shif/dtiph, shift
      common /tofev/ttvols
      common /fcont/ifcont
      logical ifcont
      character *1 cr
      dimension vecx(1)
      logical chasit, itvol, imamin, shift
      ! ENVELOPE
      call stapl(davtot*10.)
      ! xx       ilost=0
      twopi = 2.*pi
      freq = fh/twopi
      wavel = vl/freq
      fcpi = fh*180./pi
      ! print out on terminal of transport element # on one and the same line
      nrbunc = nrbunc + 1
      cr = char(13)
      write (6, 8254) nrtre, nrbunc, cr
8254  format ('Transport element:', i5, '      Buncher             :', i5, a1, $)
      if (harm<=0.) harm = 1.
      rhs = prlim*prlim
      ! test window
      call reject(ilost)
      ! Reshuffles f(i,j) array after window (now done in 'reject')
      ! call shuffle
      tcog = 0.
      bcog = 0.
      do np = 1, ngood
        tcog = tcog + f(6, np)
        gpa = f(7, np)/xmat
        bcog = sqrt(1.-1./(gpa*gpa)) + bcog
      end do
      tcog = tcog/float(ngood)
      bcog = bcog/float(ngood)
      gcog = 1./sqrt(1.-bcog*bcog)
      encog = xmat*gcog - xmat
      ! adjustement of the phase of RF w.r.t. the T.O.F.
      xkpi = 0.
      if (imamin) then
        ttvpi = harm*ttvols*fcpi
        xkpi = ttvpi/360.
        ixkpi = int(xkpi)
        xkpi = (xkpi-float(ixkpi))*360.
        write (16, *) ' *** TOF correction:', -xkpi, ' deg'
        dp = dp - xkpi*pi/180.
        write (16, *) ' ***phase of RF adjusted : ', dp*180./pi, ' deg'
      end if
      ! 20/08/2009    delay of phase of the reference at input w.r.t. the synchronous phase
      ! 20/08/2009       ttvpi=harm*ttvols*fcpi
      ! 20/08/2009       xkpi=ttvpi/180.
      ! 20/08/2009       ixkpi=xkpi+0.5
      ! 20/08/2009       ixkpi=ixkpi*180
      ! 20/08/2009       xkpc=cos(ixkpi*pi/180.)
      ! 20/08/2009       xkpi=ttvpi-float(ixkpi)
      ! 20/08/2009       if(itvol.and.imamin)
      ! 20/08/2009     *  write(16,8975) dp*180./pi,xkpi
      ! 20/08/2009 8975   format('***previous phase offset: ',e12.5,' deg',/,
      ! 20/08/2009     * '***new phase offset: ',e12.5,' deg')
      ! start of write to file '.short' for buncher
      idav = idav + 1
      iitem(idav) = 8
      dav1(idav, 1) = v
      dav1(idav, 2) = dp*180./pi
      dav1(idav, 3) = prlim
      dav1(idav, 4) = davtot*10.
      if (itvol) dav1(idav, 5) = -xkpi
      ! end
      write (16, 178)
178   format (/, ' Dynamics at the input', /, 5x, '   BETA     GAMMA      ENERGY(MeV) ', '       TOF(deg)     TOF(sec)')
      write (16, 1788) bcog, gcog, encog, tcog*fcpi, tcog
1788  format (' COG ', f7.5, 3x, e12.5, 1x, e12.5, 3x, e12.5, 3x, e12.5)
      e0t = harm*v/(bcog*wavel)
      ! random or systematic error on  RF level
      if (ierpf>0) then
        ! systematic error on RF level
        if (ierpf==1) e0t = e0t*(1.+vfield)
        ! random error on RF level
        if (ierpf>=2) then
          len = 1
          call rlux(vecx, len)
          r1 = (2.*vecx(1)-1.)*vfield
          e0t = e0t*(1.+r1)
        end if
      end if
      cay = harm*twopi/(bcog*gcog*wavel)
      caysq = cay**2
      con = twopi*e0t*qmoy/xmat
      rad = pi/180.
      ! systematic error on  phase
      if (ierpf==1) dp = dp + vphase*rad
      ! random error on phase
      if (ierpf>=2) then
        len = 1
        call rlux(vecx, len)
        r1 = (2.*vecx(1)-1.)*vphase*rad
        dp = dp + r1
      end if
      ! shift=true => reference and COG seperated, otherwise reference=COG
      ! --- save the reference
      ovref = vref
      otref = tref
      ! --- shift = false: the reference particle is the cog
      if (shift) then
        ovref = vref
        beref = vref/vl
        gamref = 1./sqrt(1.-beref*beref)
        older = xmat*gamref
      else
        tref = tcog
        vref = bcog*vl
        ovref = vref
        beref = bcog
        gamref = 1./sqrt(1.-beref*beref)
        older = xmat*gamref
      end if
      ! ---  if imamin = false: phase setting has been forced equal to dp, otherwise phase setting has been adjusted
      dgr = v*cos(harm*ttvols*fh+dp)*qmoy
      ewer = older + dgr
      gor = ewer/xmat
      vref = vl*sqrt(1.-1./(gor*gor))
      enrprin = older - xmat
      write (16, 165) beref, gamref, enrprin, tref*fh*180./pi, tref
165   format (' REF ', f7.5, 3x, e12.5, 1x, e12.5, 3x, e12.5, 3x, e12.5)
      wsync = 0.
      bcour = 0.
      tcog = 0.
      do np = 1, ngood
        rs = f(2, np)**2 + f(4, np)**2
        a = harm*(f(6,np)-tref+ttvols)*fh + dp
        rs = rs*1.e-04
        ! 20/08/2009         s=sin(a)*xkpc
        s = sin(a)
        w = f(7, np) - xmat
        bg = sqrt(w/xmat*(2.+w/xmat))
        ! conversion cm-->m and mrd--->rd
        f2 = f(2, np)
        f4 = f(4, np)
        f3 = f(3, np)*1.e-03
        f5 = f(5, np)*1.e-03
        bgx = f3*bg
        bgy = f5*bg
        cayrsq = caysq*rs
        arg = cayrsq/4.
        xi0 = 1. + arg*(1.+arg*(.25+arg/36.))
        ! dw=v*cos(a)*xi0*qmoy
        dw = v*cos(a)*xi0*f(9, np)
        ! 20/08/2009         dw=dw*xkpc
        wb = w + .5*dw
        bgav = sqrt(wb/xmat*(2.+wb/xmat))
        gav = 1. + wb/xmat
        bav = bgav/gav
        bcour = bcour + bav
        wf = w + dw
        bgf = sqrt(wf/xmat*(2.+wf/xmat))
        xi1okr = .5 + .25*arg + arg**2/24.
        del = -con*s*(1.-bav*bcog)*xi1okr/bav
        tcog = tcog + f(6, np)
        f3 = (bgx+del*f2)/bgf
        f(3, np) = f3*1.e03
        f5 = (bgy+del*f4)/bgf
        f(5, np) = f5*1.e03
        f(7, np) = wf + xmat
        wsync = wsync + wf
      end do
      wsync = wsync/float(ngood)
      bcour = bcour/float(ngood)
      tcog = tcog/float(ngood)
      ! Test window
      call reject(ilost)
      ! Reshuffles f(i,j) array after window (now done in 'reject')
      ! call shuffle
      ! new output
      ! shift=true => reference and COG seperated, otherwise reference=COG
      engain = wsync - encog
      if (shift) then
        beref = vref/vl
        gamref = 1./sqrt(1.-beref*beref)
        enref = ewer - xmat
      else
        tref = tcog
        vref = bcour*vl
        beref = bcour
        enref = wsync
        dgr = engain
      end if
      if (itvol) ttvols = tref
      write (16, 3777)
3777  format (/, ' Dynamics at the output', /, 5x, '   BETA     dW(MeV)    ENERGY(MeV) ', '   TOF(deg)     TOF(sec)')
      write (16, 3473) beref, dgr, enref, fh*tref*180./pi, tref
3473  format (' REF ', f7.5, 3x, f10.6, 3x, f8.3, 3x, e12.5, 3x, e12.5)
      write (16, 1789) bcour, engain, wsync, tcog*fh*180./pi, tcog
1789  format (' COG ', f7.5, 3x, f10.6, 3x, f8.3, 3x, e12.5, 3x, e12.5)
      ! dave start for buncher
      dav1(idav, 36) = ngood
      ! as beam passed through buncher, assume bunched beam
      ifcont = .false.
      write (16, *) 'After buncher, bunched beam assumed'
      call emiprt(0)
      ! dave end
      ! xx3928   FORMAT(' # ',i5,1x,7(f10.2,1x))
      return
    end subroutine bunparm
    ! *******************************************************************
    ! SUBROUTINE refer
    ! change the longitudinal position of the reference

    ! ---- IREF =0 and IREFW = 0:  dewref is dW/W where W is the kinetic
    ! energy of the old reference
    ! ---- IREF =0 and IREFW = 1:  dewref is dW (MeV) relative to the
    ! kinetic energy of the old reference
    ! ---- IREF =0 and IREFW = 2:  dewref is dW (MeV) is new reference
    ! energy and dbref new reference
    ! phase (deg) in abs. units
    ! ---- IREF =1 and IREFW = 0:  dewref is dW/W where W is the kinetic
    ! energy of the c.o.g
    ! ---- IREF =1 and IREFW = 1:  dewref is dW (MeV) relative to the
    ! kinetic energy of the c.o.g.
    ! *******************************************************************
    subroutine refer
      implicit real *8(a-h, o-z)
      parameter(iptsz=100002, maxcell=3000, maxcell1=3000)
      common /ttfc/tk, t1k, t2k, sk, s1k, s2k, fh
      common /dyn/tref, vref
      common /faisc/f(10, iptsz), imax, ngood
      common /qmoyen/qmoy
      common /consta/vl, pi, xmat, rpel, qst
      common /newref/dephas, dewref, iref, irefw
      common /tapes/in, ifile, meta
      common /itvole/itvol, imamin
      common /tofev/ttvols
      logical itvol, imamin
      ! ---- save  reference
      avref = vref
      atref = tref
      attvols = ttvols
      if (irefw==2) then
        wnref = dewref
        gnref = wnref/xmat + 1.
        bref = sqrt(gnref*gnref-1.)/gnref
        ! ---- set tref in sec based on dephas (deg)
        delt = dephas*pi/(fh*180.)
        ! ------ the new reference is:
        tref = delt
        vref = bref*vl
        if (itvol) ttvols = tref
      end if
      if (iref==0) then
        if (irefw==0) then
          bref = vref/vl
          gref = 1./sqrt(1-bref*bref)
          dbref = bref*dewref/(gref*(gref+1.))
          ! ---- change dephas (deg) in delt (sec)
          delt = dephas*pi/(fh*180.)
          ! ------ the new reference is:
          tref = tref + delt
          vref = vref + dbref*vl
          if (itvol) ttvols = tref
        end if
        if (irefw==1) then
          bref = vref/vl
          gref = 1./sqrt(1.-bref*bref)
          wref = (gref-1.)*xmat
          wnref = wref + dewref
          gnref = wnref/xmat + 1.
          bref = sqrt(gnref*gnref-1.)/gnref
          ! ---- change dephas (deg) in delt (sec)
          delt = dephas*pi/(fh*180.)
          ! ------ the new reference is:
          tref = tref + delt
          vref = bref*vl
          if (itvol) ttvols = tref
        end if
      end if
      if (iref==1) then
        ! ----- c.o.g. of the bunch is the new reference
        tcog = 0.
        bcog = 0.
        do i = 1, ngood
          tcog = tcog + f(6, i)
          gpai = f(7, i)/xmat
          bcog = bcog + sqrt(1.-1./(gpai*gpai))
        end do
        tcog = tcog/float(ngood)
        bcog = bcog/float(ngood)
        gcog = 1./sqrt(1-bcog*bcog)
        wcog = (gcog-1.)*xmat
        ! ---- change dephas (deg) in delt (sec)
        delt = dephas*pi/(fh*180.)
        if (irefw==0) then
          wrefn = wcog + wcog*dewref/100.
          ! ------ the new reference is:
          tref = tcog + delt
          ! vref=(bcog+dbcog)*vl
          grefn = wrefn/xmat + 1.
          vref = vl*sqrt(grefn*grefn-1.)/grefn
          if (itvol) ttvols = tref
        end if
        if (irefw==1) then
          wncog = wcog + dewref
          gncog = wncog/xmat + 1.
          bcog = sqrt(gncog*gncog-1.)/gncog
          ! ------ the new reference is:
          tref = tcog + delt
          vref = bcog*vl
          if (itvol) ttvols = tref
        end if
      end if
      baref = avref/vl
      garef = 1./sqrt(1.-baref*baref)
      waref = (garef-1.)*xmat
      bnref = vref/vl
      gnref = 1./sqrt(1.-bnref*bnref)
      wnref = (gnref-1.)*xmat
      fcpi = fh*180/pi
      write (16, 20) atref*fcpi, attvols*fcpi, waref
20    format (3x, '**before NREF', /, 5x, 'tof of the reference: ', e12.5, ' deg tof for adjustments: ', e12.5, &
        ' deg energy of reference: ', e12.5, ' MeV')
      write (16, 21) tref*fcpi, ttvols*fcpi, wnref
21    format (3x, '**after NREF', /, 5x, 'tof of the reference: ', e12.5, ' deg tof for adjustments: ', e12.5, &
        ' deg energy of reference: ', e12.5, ' MeV')
      return
    end subroutine refer
    ! *******************************************************************
    ! SUBROUTINE steer(fld,nvf)
    ! TRANSFORM BEAM THRU THIN STEERER
    ! ---- MAGNETIC STEERER
    ! ---- PARAMETERS: fld (Tm), nvf
    ! where fld is the integrated field
    ! if nvf=0,  horizontal magnetic steerer
    ! if nvf=1,  vertical magnetic steerer

    ! ---- ELECTROSTATIC STEERER
    ! This is a zero length element: the length shown below is
    ! ONLY used for kick calculation.
    ! ---- PARAMETERS: fld (kV*m/m), nvf
    ! where fld is Plate Voltage * plate length/plate separation.
    ! if nvf=2, horziontal electrostatic steerer
    ! if nvf=3, vertical electrostatic steerer

    ! -----ANGULAR DISPLACEMENTS DUE TO STEERING
    ! *******************************************************************
    subroutine steer(fld, nvf)
      implicit real *8(a-h, o-z)
      ! 4/15/14 - Daniel Alt: Added electrostatic steerers.
      parameter(iptsz=100002, maxcell=3000, maxcell1=3000)
      common /ttfc/tk, t1k, t2k, sk, s1k, s2k, fh
      common /dyn/tref, vref
      common /consta/vl, pi, xmat, rpel, qst
      common /rigid/boro
      common /faisc/f(10, iptsz), imax, ngood
      common /etcom/cog(8), exten(17), fd(iptsz)
      common /qmoyen/qmoy
      common /dcspa/iesp
      common /sc3/beamc, scdist, sce10, cplm, ect, apl, ichaes, iscsp
      common /tapes/in, ifile, meta
      common /pltprf/sprfx(3000), sprfy(3000), sprfl(3000), sprfw(3000), sprfp(3000), sprng(3000), iprf
      common /davcom/dav1(maxcell1, 40), davtot, iitem(maxcell1), idav
      common /compt/nrres, nrtre, nrbunc, nrdbun
      character *1 cr
      logical iesp, ichaes
      ! print out on terminal of transport element # on one and the same line
      nrtre = nrtre + 1
      cr = char(13)
      write (6, 8254) nrtre, nrres, cr
8254  format ('Transport element:', i5, '      Accelerating element:', i5, a1, $)
      if (nvf==0) then
        ! horizontal magnetic steerer
        write (16, *) 'Horizontal magnetic steerer: ', fld, ' Tm'
        do i = 1, ngood
          const = xmat*1.e8/(f(9,i)*vl)
          gpai = f(7, i)/xmat
          bpai = sqrt(1.-1./(gpai*gpai))
          dispx = fld/(const*gpai*bpai)*1000.
          f(3, i) = f(3, i) + dispx
        end do
      else if (nvf==1) then
        ! vertical magnetic steerer
        write (16, *) 'Vertical magnetic steerer: ', fld, ' Tm'
        do i = 1, ngood
          const = xmat*1.e8/(f(9,i)*vl)
          gpai = f(7, i)/xmat
          bpai = sqrt(1.-1./(gpai*gpai))
          dispy = fld/(const*gpai*bpai)*1000.
          f(5, i) = f(5, i) + dispy
        end do
      else if (nvf==2) then
        ! horizontal electrostatic steerer
        write (16, *) 'Horizontal electrostatic steerer: ', fld, ' kV*m/m'
        do i = 1, ngood
          gpai = f(7, i)/xmat
          const = (gpai/(gpai*gpai-1.))*f(9, i)
          dispx = const*fld/xmat
          f(3, i) = f(3, i) + dispx
        end do
      else if (nvf==3) then
        ! vertical electrostatic steerer
        write (16, *) 'Vertical electrostatic steerer: ', fld, ' kV*m/m'
        do i = 1, ngood
          gpai = f(7, i)/xmat
          const = (gpai*gpai/(gpai*gpai-1.))*f(9, i)
          dispy = const*fld/xmat
          f(5, i) = f(5, i) + dispy
        end do
      else
        ! error on input
        write (16, *) 'Wrong value for NVF in STEERER'
        stop
      end if
      return
    end subroutine steer
    ! *******************************************************************
    ! SUBROUTINE emiprt(L)
    ! following EMIT or EMITL card, store data in arrays to be printed
    ! by subroutine "daves"
    ! L=0 corresponds to EMIT (do not read and print a label)
    ! L=1 corresponds to EMITL (do read and print a label in dynac.short)
    ! look for the statistics with EXT2D and returns them in arrays dav1
    ! and dav2
    ! IDCH EQ 1: WITH  CHASE TEST
    ! IDCH NE 1: OTHERWISE

    ! cog(1) : Energy(MeV)
    ! cog(3) : t.o.f. (sec)
    ! cog(4) : x-direction (cm)
    ! cog(5) : xp(mrd)
    ! cog(6) : y-direction (cm)
    ! cog(7) : yp(mrd)

    ! exten(1) : Sum( dE*dE )  MeV*MeV
    ! exten(2) : Sum( dE*dPHase ) MeV*rad
    ! exten(3) : Sum( dPHase*dPHase ) rad*rad
    ! exten(4) : Sum( x*x )   cm*cm
    ! exten(5) : Sum( xp*xp )   mrad*mrad
    ! exten(6) : Sum( y*y )   cm*cm
    ! exten(7) : Sum( yp*yp )  mrad*mrad
    ! exten(8) : Sum( x*xp )   cm*mrad
    ! exten(9) : Sum( y*yp )   cm*mrad
    ! *******************************************************************
    subroutine emiprt(l)
      implicit real *8(a-h, o-z)
      parameter(iptsz=100002, maxcell=3000, maxcell1=3000)
      common /etchas/fractx, fracty, fractl
      common /dyn/tref, vref
      common /faisc/f(10, iptsz), imax, ngood
      common /davcom/dav1(maxcell1, 40), davtot, iitem(maxcell1), idav
      common /davprt/shortl
      common /qmoyen/qmoy
      common /etcom/cog(8), exten(17), fd(iptsz)
      common /etcha1/dav2(maxcell1, 33), ichas(iptsz), chasit
      common /etcha3/ichxyz(iptsz)
      common /speda/dave, idave
      common /cptemit/xltot(maxcell1), nbemit
      common /consta/vl, pi, xmat, rpel, qst
      common /ttfc/tk, t1k, t2k, sk, s1k, s2k, fh
      common /mcs/imcs, ncstat, cstat(20)
      common /strip/atm, qs, atms, ths, qop, sqst(6), anp, nqst
      common /shortl/davprt
      logical dave, chasit
      dimension foo(20, 9), ndp(20)
      character *80 davprt(maxcell1), shortl

      nbemit = nbemit + 1
      do i = 1, ngood
        ichxyz(i) = 1
      end do
      xltot(nbemit) = davtot
      idav = idav + 1
      iitem(idav) = 3
      dav1(idav, 40) = fh
      do i = 1, ngood
        ichas(i) = 1
      end do
      iarg = 1
      if (l==1) davprt(idav) = shortl
      call cdg(iarg)
      encog = cog(1)
      gcog = encog/xmat
      bcog = sqrt(1.-1./(gcog*gcog))
      tcog = cog(3)
      call ext2d(1)
      ! --- qdisp : average dispersion (MeV)
      ! --- sqmdv:  emittance (MeV*rad)
      qdisp = 2.*sqrt(exten(1))
      qmdv = exten(1)*exten(3) - exten(2)*exten(2)
      sqmdv = 4.*pi*sqrt(qmdv)
      ! --- qdp : average extension in phase (rad)
      qdp = 2.*sqrt(exten(3))
      ! --- cor12: coefficient of correlation in (dE, dPHI)
      cor12 = exten(2)/sqrt(exten(1)*exten(3))
      ! sup       pent12=sqrt(exten(1)/exten(3))/cor12
      ! sup       pent21=sqrt(exten(1)/exten(3))*cor12
      ! sup       qdpde=qdp*180./pi
      ! ---  particle reference
      ! dav1(idav,3): relativistic beta
      ! dav1(idav,4): Kinetic energy (MeV)
      ! dav1(idav,5): phase (in deg. w.r.t. k*pi)
      beref = vref/vl
      gref = 1./sqrt(1.-beref*beref)
      dav1(idav, 3) = beref
      dav1(idav, 4) = xmat*(gref-1.)
      dav1(idav, 5) = -(int(tref*fh/pi+0.5)-tref*fh/pi)*180.
      ! print out absolute TOF
      dav1(idav, 5) = (tref*fh/pi)*180.
      ! ---  c.o.g of the bunch
      ! dav1(idav,6): Kinetic energy (MeV)
      ! dav1(idav,7): phase (in deg. w.r.t. k*pi)
      phnw = -(int(tcog*fh/pi+0.5)-tcog*fh/pi)*180.
      ! print out absolute TOF
      phnw = (tcog*fh/pi)*180.
      dav1(idav, 6) = encog - xmat
      dav1(idav, 7) = phnw
      ! ---- deviation between the fictious reference and the c.o.g. of the bunch
      ! dav1(idav,8) : deviation in energy (MeV)
      ! dav1(idav,9) : deviation of phase (deg)
      dav1(idav, 8) = encog - xmat - dav1(idav, 4)
      dav1(idav, 9) = phnw - dav1(idav, 5)
      ! ---- statistics in z-zp
      ! --- dav1(idav,10) :  extension dPHI (deg)
      ! --- dav1(idav,11) :  dispersion dE (MeV)
      ! --- dav1(idav,12) :  emittance (MeV*rad)
      ! --- dav1(idav,23) :  correlation in  between dE an dPHI
      dav1(idav, 10) = qdp*180./pi
      dav1(idav, 11) = qdisp
      dav1(idav, 12) = sqmdv/pi
      dav1(idav, 23) = cor12
      ! sup       dav1(idav,39)=sqmdv*180./(pi*pi)
      ! sup       Ez(ns.keV)
      ! sup       dav1(idav,12)=sqmdv*(1.E09)/(pi*fh)
      ! ---- statistics in x-xp and y-yp
      trqtx = exten(4)*exten(5) - exten(8)*exten(8)
      trqpy = exten(6)*exten(7) - exten(9)*exten(9)
      surxth = 4.*pi*sqrt(trqtx)
      suryph = 4.*pi*sqrt(trqpy)
      qditax = 2.*sqrt(exten(4))
      qdiant = 2.*sqrt(exten(5))
      qditay = 2.*sqrt(exten(6))
      qdianp = 2.*sqrt(exten(7))
      ! dav1(idav,13): extension in x (mm)
      ! dav1(idav,14): extension in xp (mrad)
      ! --- dav1(idav,15): correlation between x and xp
      dav1(idav, 13) = qditax*10.
      dav1(idav, 14) = qdiant
      dav1(idav, 15) = 0.
      if (exten(4)/=0. .and. exten(5)/=0.) dav1(idav, 15) = exten(8)/sqrt(exten(4)*exten(5))
      ! Emittance(norm)  x-xp (mm*mrad)
      dav1(idav, 16) = bcog*surxth*10./(pi*sqrt(1.-bcog*bcog))
      ! Emittance(non norm) x-xp (mm*mrad)
      dav1(idav, 17) = surxth*10./pi
      ! --- dav1(idav,18): y-extension  (mm)
      ! --- dav1(idav,19): yp-extension (mrad)
      ! --- dav1(idav,20): correlation between y and yp
      dav1(idav, 20) = 0.
      if (exten(6)/=0. .and. exten(7)/=0.) dav1(idav, 20) = exten(9)/sqrt(exten(6)*exten(7))
      dav1(idav, 18) = qditay*10.
      dav1(idav, 19) = qdianp
      ! dav1(idav,21) : Emittance(norm) y-yp (pi*mm*mrad)
      dav1(idav, 21) = bcog*suryph*10./(pi*sqrt(1.-bcog*bcog))
      ! dav1(idav,22) : Emittance(non norm) y-yp (mm*mrad)
      dav1(idav, 22) = suryph*10./pi
      dav1(idav, 30) = float(ngood)
      dav1(idav, 31) = cog(4)*10.
      dav1(idav, 32) = cog(5)
      dav1(idav, 33) = cog(6)*10.
      dav1(idav, 34) = cog(7)
      ! next card to indicate no chase
      dav1(idav, 26) = 0.
      ! --- statistics with chase
      if (chasit) then
        dav2(idav, 31) = fractx
        dav2(idav, 32) = fracty
        dav2(idav, 33) = fractl
        ! longitudinal direction
        call chasel
        do i = 1, ngood
          ichxyz(i) = ichas(i)
        end do
        iarg = 1
        call cdg(iarg)
        encog = cog(1)
        gcog = encog/xmat
        bcog = sqrt(1.-1./(gcog*gcog))
        enprt = encog - xmat
        call ext2d(1)
        ! qdisp : average dispersion dE (MeV)
        ! sqmdv: longitudinal emittance (MeV*rad)
        qdisp = 2.*sqrt(exten(1))
        qmdv = exten(1)*exten(3) - exten(2)*exten(2)
        sqmdv = 4.*pi*sqrt(qmdv)
        ! qdp : average extension dPHI (rad)
        qdp = 2.*sqrt(exten(3))
        ! cor12: coefficient of correlation in (dE, dPHI)
        cor12 = exten(2)/sqrt(exten(1)*exten(3))
        ! sup       pent12=sqrt(exten(1)/exten(3))/cor12
        ! sup       pent21=sqrt(exten(1)/exten(3))*cor12
        ! sup       qdpde=qdp*180./pi
        ! ---  fictitious reference
        ! dav2(idav,3): relativistic beta
        ! dav2(idav,4): Kinetic energy (MeV)
        ! dav2(idav,5): phase (in deg. w.r.t. k*pi)
        beref = vref/vl
        gref = 1./sqrt(1.-beref*beref)
        dav2(idav, 3) = beref
        dav2(idav, 4) = xmat*(gref-1.)
        dav2(idav, 5) = (int(tref*fh/pi+0.5)-tref*fh/pi)*180.
        ! ---  c.o.g of the bunch
        ! dav2(idav,6): Kinetic energy (MeV)
        ! dav2(idav,7): phase (in deg. w.r.t. k*pi)
        phnw = -(int(tcog*fh/pi+0.5)-tcog*fh/pi)*180.
        dav2(idav, 6) = encog - xmat
        dav2(idav, 7) = phnw
        ! ---- deviation between fictitious reference and c.o.g.
        ! dav2(idav,8) : deviation in energy (MeV)
        ! dav2(idav,9) : deviation of phase (deg)
        dav2(idav, 8) = encog - xmat - dav2(idav, 4)
        dav2(idav, 9) = phnw - dav2(idav, 5)
        ! ---- caracteristics of the bunch in longitudinal plane (dE, dPHI)
        ! dav2(idav,10) :  dPHI extension (deg)
        ! dav2(idav,11) :  dispersion dE (MeV)
        ! dav2(idav,12) :  emittance (MeV*rad)
        ! dav2(idav,23) :  coefficient of correlation in  (dE, dPHI)
        dav2(idav, 10) = qdp*180./pi
        dav2(idav, 11) = qdisp
        dav2(idav, 12) = sqmdv/pi
        dav2(idav, 23) = cor12
        ! sup       dav2(idav,39)=sqmdv*180./(pi*pi)
        ! sup       Ez(ns.keV)
        ! sup       dav2(idav,12)=sqmdv*(1.E09)/(pi*fh)
        ! ---  chase in x-xp
        call chasex
        do i = 1, ngood
          ichxyz(i) = ichas(i)*ichxyz(i)
        end do
        iarg = 1
        call cdg(iarg)
        encog = cog(1)
        gcog = encog/xmat
        bcog = sqrt(1.-1/(gcog*gcog))
        dav2(idav, 26) = cog(4)*10.
        dav2(idav, 27) = cog(5)
        call ext2d(1)
        trqty = exten(4)*exten(5) - exten(8)*exten(8)
        surxth = 4.*pi*sqrt(trqty)
        qditax = 2.*sqrt(exten(4))
        qdiant = 2.*sqrt(exten(5))
        ! cc below for fourth line of EMIT output
        ! ---- caracteristics of the bunch in x-direction
        ! dav2(idav,13): x-extension (mm)
        ! dav2(idav,14): xp-extension (mrad)
        ! dav2(idav,15): coefficient of correlation in plane (x, xp)
        dav2(idav, 13) = qditax*10.
        dav2(idav, 14) = qdiant
        dav2(idav, 15) = 0.
        if (exten(4)/=0. .and. exten(5)/=0.) dav1(idav, 15) = exten(8)/sqrt(exten(4)*exten(5))
        ! Emittance(norm) x-xp (pi*mm*mrad)
        dav2(idav, 16) = bcog*surxth*10./(pi*sqrt(1.-bcog*bcog))
        ! Emittance(non norm) in x-xp (mm*mrad)
        dav2(idav, 17) = surxth*10./pi
        ! cc below for fourth line of EMIT output
        ! ---  chase in x-xp
        call chasey
        do i = 1, ngood
          ichxyz(i) = ichas(i)*ichxyz(i)
        end do
        iarg = 1
        call cdg(iarg)
        encog = cog(1)
        gcog = encog/xmat
        bcog = sqrt(1.-1./(gcog*gcog))
        dav2(idav, 28) = cog(6)*10.
        dav2(idav, 29) = cog(7)
        call ext2d(1)
        trqpz = exten(6)*exten(7) - exten(9)*exten(9)
        suryph = 4.*pi*sqrt(trqpz)
        qditay = 2.*sqrt(exten(6))
        qdianp = 2.*sqrt(exten(7))
        ! dav2(idav,18): y-extension  (mm)
        ! dav2(idav,19): yp-extension (mrad)
        ! dav2(idav,20): coefficient of correlation in the plane (y, yp)
        dav2(idav, 20) = 0.
        if (exten(6)/=0. .and. exten(7)/=0.) dav2(idav, 20) = exten(9)/sqrt(exten(6)*exten(7))
        dav2(idav, 18) = qditay*10.
        dav2(idav, 19) = qdianp
        ! dav2(idav,21) : Emittance(norm) in y-yp (mm*mrad)
        dav2(idav, 21) = bcog*suryph*10./(pi*sqrt(1.-bcog*bcog))
        ! dav1(idav,22) : Emittance(non norm) in y-yp (mm*mrad)
        dav2(idav, 22) = suryph*10./pi
        ! next card to indicate chase
        dav1(idav, 26) = 1.
        do i = 1, ngood
          ichas(i) = 1
        end do
      end if
      ! print energy, boro etc for each charge state in long
      if (ncstat>1) then
        write (16, '(1x,a4)') 'EMIT'
        do k = 1, ncstat
          ndp(k) = 0
          do j = 2, 7
            foo(k, j) = 0.
          end do
        end do
        do i = 1, imax
          if (f(8,i)==1) then
            do k = 1, ncstat
              if (f(9,i)==cstat(k)) then
                ndp(k) = ndp(k) + 1
                do j = 2, 7
                  foo(k, j) = foo(k, j) + f(j, i)
                end do
              end if
            end do
          end if
        end do
        do k = 1, ncstat
          if (ndp(k)/=0) then
            do j = 2, 7
              foo(k, j) = foo(k, j)/float(ndp(k))
            end do
          end if
        end do
        write (16, *) ' Q     Particles  beta       Wcog(MeV)', &
          '    Wcog(MeV/u)  Pcog(kG.cm)     TOF(deg)   TOF(sec)   ', '     X_avg(cm)     Xp_avg(mrad)  ', &
          'Y_avg(cm)     Yp_avg(mrad)'
        do k = 1, ncstat
          if (ndp(k)/=0) then
            gref = foo(k, 7)/xmat
            bref = sqrt(1.-1./(gref*gref))
            xe = (gref-1.)*xmat
            ! magnetic rigidity
            bor = 3.3356*xmat*bref*gref/cstat(k)
            write (16, '(2x,f5.2,3x,I5,5x,F9.7,                                 5(1x,E12.5),1x,4(F12.5,2x))') cstat(k), &
              ndp(k), bref, xe, xe/atm, bor, foo(k, 6)*180.*fh/pi, foo(k, 6), foo(k, 2), foo(k, 3), foo(k, 4), foo(k, 5)
          else
            write (16, '(2x,f5.2,3x,I5)') cstat(k), ndp(k)
          end if
        end do
        write (16, *)
      end if
      return
    end subroutine emiprt
    ! *******************************************************************
    ! SUBROUTINE emit3d
    ! get beam data following RDBEAM for TRACE3D file
    ! *******************************************************************
    subroutine emit3d
      implicit real *8(a-h, o-z)
      parameter(iptsz=100002, maxcell=3000, maxcell1=3000)
      common /dyn/tref, vref
      common /faisc/f(10, iptsz), imax, ngood
      common /qmoyen/qmoy
      common /etcom/cog(8), exten(17), fd(iptsz)
      common /consta/vl, pi, xmat, rpel, qst
      common /trace3d/trace3h(100), trace3t(maxcell1), tif, kt3h, kt3t, fid
      common /trace3e/tracebi(6), traceei(3)
      character *128 trace3h, trace3t, tif

      iarg = 1
      call cdg(iarg)
      call ext2d(1)
      ! --- qdisp : average dispersion (MeV)
      ! --- sqmdv:  emittance (MeV*rad)
      qdisp = 2.*sqrt(exten(1))
      qmdv = exten(1)*exten(3) - exten(2)*exten(2)
      sqmdv = 4.*pi*sqrt(qmdv)
      ! --- qdp : average extension in phase (rad)
      qdp = 2.*sqrt(exten(3))
      ! --- cor12: coefficient of correlation in (dE, dPHI)
      cor12 = exten(2)/sqrt(exten(1)*exten(3))
      ! ---- statistics in x-xp and y-yp
      trqtx = exten(4)*exten(5) - exten(8)*exten(8)
      trqpy = exten(6)*exten(7) - exten(9)*exten(9)
      surxth = 4.*pi*sqrt(trqtx)
      suryph = 4.*pi*sqrt(trqpy)
      qditax = 2.*sqrt(exten(4))
      qdiant = 2.*sqrt(exten(5))
      qditay = 2.*sqrt(exten(6))
      qdianp = 2.*sqrt(exten(7))
      ! trace3d
      ! x-xp (mm*mrad)
      emitx = surxth*10./pi
      sgn = 1.
      if (exten(4)/=0. .and. exten(5)/=0.) sgn = exten(8)/sqrt(exten(4)*exten(5))
      betax = qditax*10.*qditax*10./emitx
      gamx = qdiant*qdiant/emitx
      alphax = sqrt(betax*gamx-1.)
      if (sgn>0.) alphax = -alphax
      ! y-yp (mm*mrad)
      emity = suryph*10./pi
      sgn = 1.
      if (exten(6)/=0. .and. exten(7)/=0.) sgn = exten(9)/sqrt(exten(6)*exten(7))
      betay = qditay*10.*qditay*10./emity
      gamy = qdianp*qdianp/emity
      alphay = sqrt(betay*gamy-1.)
      if (sgn>0.) alphay = -alphay
      ! z-zp (keV*deg)
      emitz = sqmdv/pi*1000.*(180./pi)
      betaz = qdp*180./pi*qdp*180./pi/emitz
      gamz = qdisp*1000.*qdisp*1000./emitz
      alphaz = sqrt(betaz*gamz-1.)
      if (cor12>0.) alphaz = -alphaz
      ! store parameters for trace3d
      tracebi(1) = alphax
      tracebi(2) = betax
      tracebi(3) = alphay
      tracebi(4) = betay
      tracebi(5) = alphaz
      tracebi(6) = betaz
      traceei(1) = emitx
      traceei(2) = emity
      traceei(3) = emitz
      return
    end subroutine emit3d
    ! *******************************************************************
    ! SUBROUTINE statis
    ! statitics of the 6-d ellipsoid (for print)
    ! calls EXT2D:
    ! exten(1) : Sum( dE(i)*dE(i) )  MeV*MeV
    ! exten(2) : Sum( dE(i)*dPHase(i) ) MeV*rad
    ! exten(3) : Sum( dPHase(i)*dPHase(i) ) rad*rad
    ! exten(4) : Sum( x(i)*x(i) )   cm*cm
    ! exten(5) : Sum( xp(i)*xp(i) )   mrad*mrad
    ! exten(6) : Sum( y(i)*y(i) )   cm*cm
    ! exten(7) : Sum( yp(i)*yp(i) )  mrad*mrad
    ! exten(8) : Sum( x(i)*xp(i) )   cm*mrad
    ! exten(9) : Sum( y(i)*yp(i) )   cm*mrad
    ! *******************************************************************
    subroutine statis
      implicit real *8(a-h, o-z)
      parameter(iptsz=100002, maxcell=3000, maxcell1=3000)
      common /dyn/tref, vref
      common /ttfc/tk, t1k, t2k, sk, s1k, s2k, fh
      common /faisc/f(10, iptsz), imax, ngood
      common /qmoyen/qmoy
      common /consta/vl, pi, xmat, rpel, qst
      common /stis/surxth, suryph, enedep, ecogde, testca
      common /etcom/cog(8), exten(17), fd(iptsz)
      ! EXT2D looks for average extensions squared and returns them in EXTEN
      iarg = 1
      call cdg(iarg)
      encog = cog(1)
      gcog = encog/xmat
      bcog = sqrt(1.-1./(gcog*gcog))
      tcog = cog(3)
      bref = vref/vl
      gref = 1./sqrt(1.-bref*bref)
      enref = xmat*gref
      ccgp = (tcog-tref)*fh*180./pi
      ccgd = encog - enref
      do i = 1, ngood
        gpai = f(7, i)/xmat
        bpai = sqrt(1.-1./(gpai*gpai))
        fd(i) = bpai/bcog*gpai/gcog
      end do
      call ext2d(1)
      testca = exten(1)*exten(2)*exten(3)
      if (abs(testca)>1.e-40) then
        qdisp = 2.*sqrt(exten(1))
        qmd = exten(1)*exten(3) - exten(2)*exten(2)
        surm = 4.*pi*sqrt(qmd)*180./pi
        qdp = 2.*sqrt(exten(3))
        cor12 = exten(2)/sqrt(exten(1)*exten(3))
        ! sup         PENT12=SQRT(exten(1)/exten(3))/COR12
        ! sup         PENT21=SQRT(exten(1)/exten(3))*COR12
        qdpde = qdp*180./pi
      else
        qdisp = 0.
        qmd = 0.
        surm = 0.
        qdp = 0.
        cor12 = 0.
        pent12 = 0.
        pent21 = 0.
        qdpde = 0.
      end if
      trqtx = exten(4)*exten(5) - exten(8)*exten(8)
      trqpy = exten(6)*exten(7) - exten(9)*exten(9)
      qditax = 2.*sqrt(exten(4))
      qdiant = 2.*sqrt(exten(5))
      qditay = 2.*sqrt(exten(6))
      qdianp = 2.*sqrt(exten(7))
      surxth = 4.*pi*sqrt(trqtx)
      suryph = 4.*pi*sqrt(trqpy)
      sqmdv = 4.*pi*sqrt(qmd)
      write (16, 52) imax, ngood
52    format (4x, ' TOTAL NUMBER OF PARTICLES :', i5, '   NUMBER OF PARTICLES CONSIDERED :', i6, /)
      write (16, 1557)
1557  format (5x, ' *** TRANSVERSE AND LONGITUDINAL STATISTICS')
      write (16, 1553) cog(4), cog(5)
1553  format (4x, ' COG COORD   X : ', e12.5, ' CM  XP :', e12.5, ' MRD')
      write (16, 1556) cog(6), cog(7)
1556  format (4x, ' COG COORD   Y : ', e12.5, ' CM  YP :', e12.5, ' MRD')
      write (16, 14) ccgp, ccgd
14    format (4x, ' COG COORD dPHI: ', e12.5, ' deg dW :', e12.5, ' MeV')
      write (16, 1552) qditax, qdiant, surxth/pi
1552  format (4x, ' X :', e12.5, ' CM  XP :', e12.5, ' MRD  EMITTANCE :', e15.8, ' CM.MRD')
      write (16, 1555) qditay, qdianp, suryph/pi
1555  format (4x, ' Y :', e12.5, ' CM  YP :', e12.5, ' MRD  EMITTANCE :', e15.8, ' CM.MRD')
      write (16, 154) qdpde, qdisp, sqmdv*180./(pi*pi)
154   format (4x, ' dPHI :  ', f7.3, ' deg dW :', 3x, f7.3, 3x, 'MeV  EMITTANCE :', e15.8, ' MeV.deg', /)
      ! sup       write(16,*) ' *** ellips (dE,dPHI) '
      ! sup       write(16,19) surm,qdp,qdisp,cor12
      ! sup19     format(' area: ',e12.5,' MeV*deg  half phase extent: ',e12.5,
      ! sup     *        ' deg half energy extend: ',e12.5,' MeV',/,
      ! sup     *        ' correlation coef: ',e12.5)
      ! sup     *
      return
    end subroutine statis
    ! *******************************************************************
    ! SUBROUTINE tiltbm(icg)
    ! tilt and shift of the beam with respect to the cog
    ! TIPHA : Shift on the phase axis(DEG)
    ! TIX   : Shift in the x-direction (CM)
    ! TIY   : Shift in the y-direction   (CM)
    ! SHIFW : Change the energy position of the c.o.g.(MeV)
    ! SHIFP : Change the phase position of the c.o.g.(deg)
    ! DTIPH : Change the position of the phase (radian)
    ! ICG  : = 0 VREF and TREF are the ones of sync. particle
    ! ICG  :. NE. 0 VREF ET TREF are the ones of the c. of g.
    ! *******************************************************************
    subroutine tiltbm(icg)
      implicit real *8(a-h, o-z)
      parameter(iptsz=100002, maxcell=3000, maxcell1=3000)
      common /consta/vl, pi, xmat, rpel, qst
      common /davcom/dav1(maxcell1, 40), davtot, iitem(maxcell1), idav
      common /tilt/tipha, tix, tiy, shifw, shifp
      common /ttfc/tk, t1k, t2k, sk, s1k, s2k, fh
      common /faisc/f(10, iptsz), imax, ngood
      common /objet/fo(9, iptsz), imaxo
      common /qmoyen/qmoy
      common /rigid/boro
      common /dyn/tref, vref
      common /stis/suryth, surzph, enedep, ecogde, testca
      common /newtlt/twissa(3), itwiss
      common /histo/centre(6)
      common /shif/dtiph, shift
      common /tof/tofini
      logical shift
      common /tapes/in, ifile, meta
      common /etcom/cog(8), exten(17), fd(iptsz)

      write (16, 1) tipha, tix, tiy, shifw, shifp
1     format ('  Shift the position of the bunch', /, '    in the z-direction :', e12.5, ' DEG', /, &
        '    in the x-direction :', e12.5, ' CM ', /, '    in the y-direction :', e12.5, ' CM ', /, &
        '    shift the energy of the cog with  :', e12.5, ' MeV', /, '    shift the phase  of the cog with  :', e12.5, &
        ' deg', /)
      tipha = tipha*pi/180.
      shifp = shifp*pi/180.
      deg = fh*180./pi
      iarg = 1
      call cdg(iarg)
      encog = cog(1)
      tcog = cog(3)
      gcog = encog/xmat
      bcog = sqrt(1.-1./(gcog*gcog))
      ! --- this routine is call by the routine ENTRE with icg = 1
      ! the reference particle is the cog of the bunch
      if (icg/=0) then
        tref = tcog
        vref = vl*bcog
        vcour = vref
        gcour = gcog
        bcour = bcog
        write (16, *) '*** Before tilt and shift '
        write (16, 24) bcog, tref, tref*deg, encog - xmat
24      format (2x, '*** the reference particle is the cog:', /, ' REF AND COG: BETA :', e12.5, 2x, 'TOF :', e12.5, &
          ' SEC OR: ', e12.5, ' deg', 2x, ' ENERGY :', e12.5, ' MeV', /)
      end if
      if (icg==0) then
        vcour = vl*bcog
        bcour = bcog
        gcour = gcog
        bvref = vref/vl
        gamref = 1./sqrt(1.-bvref*bvref)
        wvref = (gamref-1.)*xmat
        write (16, *) '*** Before tilt and shift '
        write (16, *) ' the reference particle and cog are distinct'
        write (16, 16) bvref, tref, tref*deg, wvref, bcog, tcog, tcog*deg, encog - xmat
16      format (2x, '  REF: BETA ', e12.5, ' T.O.F. ', e12.5, ' SEC  OR ', e12.5, ' DG', ' ENERGY ', e12.5, ' MeV', //, &
          2x, '  COG: BETA ', e12.5, ' T.O.F. ', e12.5, ' SEC  OR ', e12.5, ' DG', ' ENERGY ', e12.5, ' MeV', /)
      end if
      do i = 1, ngood
        gapi = f(7, i)/xmat
        bepi = sqrt(1.-1./(gapi*gapi))
        fd(i) = bepi/bcour*gapi/gcour
      end do
      call ext2(1)
      ! shift of the ellipse in the longitudinal plane with regard to the cog (TILT)
      ! the slip of phase is : TIPHA
      ! the ellipsoid generated by GEBEAM and INPUT is upright
      ! qdispw=dispersion in energy
      qdispw = 2.*sqrt(exten(10))
      encrt = encog + qdispw
      gamcrt = encrt/xmat
      bcrt = sqrt(1.-1./(gamcrt*gamcrt))
      vcrt = bcrt*vl
      delv = vcrt - vcour
      ! shift of the ellipse in the transverse planes with regard to the cog
      ! DELTH ET DELPH: slips in xp and yp (mrd)
      ! horizontal plane
      delxp = 2.*sqrt(exten(5))
      ! vertical plane
      delyp = 2.*sqrt(exten(7))
      write (16, 22) qdispw, delxp, delyp
22    format (' half size in energy ', e12.5, ' MeV', /, ' half size in xp ', e12.5, ' mrd', /, ' half size in yp ', &
        e12.5, ' mrd')
      ! Shift of the ellipses in the phase spaces
      tcrt = 0.
      do i = 1, ngood
        gapi = f(7, i)/xmat
        bpai = sqrt(1.-1./(gapi*gapi))
        vpai = vl*bpai
        dv = (vpai-vcour)*tipha/(delv*fh)
        f(6, i) = f(6, i) - dv
        tcrt = tcrt + f(6, i)
        dlx = 0.
        dly = 0.
        if (delxp/=0.) dlx = f(3, i)*tix/delxp
        if (delyp/=0.) dly = f(5, i)*tiy/delyp
        f(2, i) = f(2, i) + dlx
        f(4, i) = f(4, i) + dly
      end do
      tcrt = tcrt/float(ngood)
      dtiph = 0.
      if (shifw/=0. .or. shifp/=0.) then
        shtref = shifp/fh
        enshift = encog + shifw
        gshift = enshift/xmat
        bshift = sqrt(1.-1./(gshift*gshift))
        eshift = enshift - xmat
        vshift = vl*bshift
        tshift = tcrt + shtref
        deltav = vshift - vcour
        deltat = tshift - tcog
      end if
      if (shifw==0. .and. shifp==0.) then
        enshift = encog
        eshift = enshift - xmat
        gshift = gcour
        vshift = vcour
        bshift = vshift/vl
        tshift = tcrt
        shtref = 0.
        deltav = 0.
        deltat = 0.
      end if
      do i = 1, ngood
        f(7, i) = f(7, i) + shifw
        gpai = f(7, i)/xmat
        bpai = sqrt(1.-1./(gpai*gpai))
        f(6, i) = f(6, i) + shtref
        vapi = vl*bpai
      end do
      if (itwiss==1) tref = tref + tofini
      write (16, *) ' ***After tilt and shift '
      bvref = vref/vl
      gamref = 1./sqrt(1.-bvref*bvref)
      wvref = (gamref-1.)*xmat
      write (16, 16) bvref, tref, tref*deg, wvref, bshift, tshift, tshift*deg, eshift
      do i = 1, ngood
        fo(7, i) = f(7, i)
        fo(2, i) = f(2, i)
        fo(3, i) = f(3, i)
        fo(4, i) = f(4, i)
        fo(5, i) = f(5, i)
        fo(6, i) = f(6, i)
      end do
      if (itwiss/=1) then
        dum = 0.
        write (11, *) ngood, dum, fh/(2000000.*pi)
        do i = 1, ngood
          f(2, i) = f(2, i) + centre(2)
          f(3, i) = f(3, i) + centre(3)
          f(4, i) = f(4, i) + centre(4)
          f(5, i) = f(5, i) + centre(5)
          f(6, i) = f(6, i) + centre(6)
          f(7, i) = f(7, i) + centre(1)
          etphas = fh*(f(6,i)-tcog)
          ! option          etener=f(7,i)-encog
          etener = f(7, i) - xmat
          write (11, 777) f(2, i), f(3, i)/1000., f(4, i), f(5, i)/1000., etphas, etener
        end do
777     format (6(f13.8,1x))
      end if
      ! ENVELOPE
      call stapl(davtot*10.)
      return
    end subroutine tiltbm
    ! *******************************************************************
    ! SUBROUTINE tiltbm_bis(icg)
    ! Change the positions of the beam in the phase planes
    ! TIPHA : Shift with regard to the phase axis(DEG)
    ! TIX   : Shift in the x-direction (CM)
    ! TIY   : Shift in the y-direction   (CM)
    ! SHIFW : Change the energy position of the c.o.g.(MeV)
    ! SHIFP : Change the phase position of the c.o.g.(deg)
    ! DTIPH : Change the position of the phase (radian)
    ! ICG  : = 0 VREF and TREF are the ones of sync. particle
    ! ICG  :. NE. 0 VREF ET TREF are the ones of the c. of g.
    ! *******************************************************************
    subroutine tiltbm_bis(icg)
      implicit real *8(a-h, o-z)
      parameter(iptsz=100002, maxcell=3000, maxcell1=3000)
      common /consta/vl, pi, xmat, rpel, qst
      common /davcom/dav1(maxcell1, 40), davtot, iitem(maxcell1), idav
      common /tilt/tipha, tix, tiy, shifw, shifp
      common /ttfc/tk, t1k, t2k, sk, s1k, s2k, fh
      common /faisc/f(10, iptsz), imax, ngood
      common /objet/fo(9, iptsz), imaxo
      common /qmoyen/qmoy
      common /rigid/boro
      common /dyn/tref, vref
      common /stis/suryth, surzph, enedep, ecogde, testca
      common /newtlt/twissa(3), itwiss
      common /histo/centre(6)
      common /shif/dtiph, shift
      ! omment      common/tof/tofini
      logical shift
      common /tapes/in, ifile, meta
      common /etcom/cog(8), exten(17), fd(iptsz)

      write (16, 1) tipha, tix, tiy, shifw, shifp
1     format (' shift the position around the c.o.g. of the bunch', /, '    with regard to the phase axis :', e12.5, &
        ' DEG', /, '    in the x-direction            :', e12.5, ' CM ', /, '    in the y-direction            :', &
        e12.5, ' CM ', /, '   Change of energy position of the c.o.g.  :', e12.5, ' MEV', /, &
        '   Change of phase  position of the c.o.g.  :', e12.5, ' DEG', /)
      shtref = 0.
      tipha = tipha*pi/180.
      shifp = shifp*pi/180.
      deg = fh*180./pi
      iarg = 1
      call cdg(iarg)
      encog = cog(1)
      tcog = cog(3)
      gcog = encog/xmat
      bcog = sqrt(1.-1./(gcog*gcog))
      if (icg/=0 .and. (shifw==0. .or. shifp==0.)) then
        ! the reference and the cog coincide
        tref = tcog
        vref = vl*bcog
        vcour = vref
        gcour = gcog
        bcour = bcog
        write (16, *) ' Before shift '
        write (16, 24) vref, tref, encog - xmat
24      format (2x, ' Note : reference will coincide with the cog', /, 2x, ' velocity :', e12.5, ' CM/SEC', 2x, 'tof :', &
          e12.5, ' SEC', /, 2x, ' ENERGY :', e12.5, ' MeV', /)
      else
        ! the reference is distinct from the cog
        vcour = vl*bcog
        bcour = bcog
        gcour = gcog
        bvref = vref/vl
        gamref = 1./sqrt(1.-bvref*bvref)
        wvref = (gamref-1.)*xmat
        write (16, *) ' Before shift '
        write (16, 16) vref, tref, tref*deg, wvref, vcour, tcog, tcog*deg, encog - xmat
      end if
      do i = 1, ngood
        gapi = f(7, i)/xmat
        bepi = sqrt(1.-1./(gapi*gapi))
        fd(i) = bepi/bcour*gapi/gcour
      end do
      call ext2(1)
      ! shift of the ellipse in the longitudinal plane with regard to the cog (TILT)
      ! the slip of phase is : TIPHA
      ! the elipsoid generated from MONTE end ENTRE is upright
      ! qdispw=dispersion in energy
      qdispw = 2.*sqrt(exten(10))
      encrt = encog + qdispw
      gamcrt = encrt/xmat
      bcrt = sqrt(1.-1./(gamcrt*gamcrt))
      vcrt = bcrt*vl
      delv = vcrt - vcour
      ! shift of the ellipse in the transverse planes with regard to the cog
      ! DELTH ET DELPH: slips in xp and yp (MRD)
      ! horizontal plane
      delxp = 2.*sqrt(exten(5))
      ! vertical plane
      delyp = 2.*sqrt(exten(7))
      write (16, 22) qdispw, delxp, delyp
22    format (' half size in energy ', e12.5, ' MeV', /, ' half size in xp ', e12.5, ' mrd', /, ' half size in yp ', &
        e12.5, ' mrd')
      ! Shift of the ellipses in the phase spaces
      tcrt = 0.
      do i = 1, ngood
        gapi = f(7, i)/xmat
        bpai = sqrt(1.-1./(gapi*gapi))
        vpai = vl*bpai
        dv = (vpai-vcour)*tipha/(delv*fh)
        f(6, i) = f(6, i) - dv
        tcrt = tcrt + f(6, i)
        dlx = 0.
        dly = 0.
        if (delxp/=0.) dlx = f(3, i)*tix/delxp
        if (delyp/=0.) dly = f(5, i)*tiy/delyp
        f(2, i) = f(2, i) + dlx
        f(4, i) = f(4, i) + dly
      end do
      tcrt = tcrt/float(ngood)
      dtiph = 0.
      ! shift=.true.: The reference and COG are independent
      ! shift=.false. The reference and COG are the same
      if (shifw/=0. .or. shifp/=0.) then
        shift = .true.
        shtref = shifp/fh
        enshift = encog + shifw
        gshift = enshift/xmat
        bshift = sqrt(1.-1./(gshift*gshift))
        eshift = enshift - xmat
        vshift = vl*bshift
        tshift = tcrt + shtref
      else
        shift = .false.
        enshift = encog
        eshift = enshift - xmat
        gshift = gcour
        vshift = vcour
        tshift = tcrt
      end if
      if (icg==0) then
        deltav = vshift - vcour
        deltat = tshift - tcog
      else
        deltav = 0.
        deltat = 0.
        shifw = 0.
        shtref = 0.
      end if
      write (16, *) 'tofini,tcrt=', tofini, tcrt, tcrt*deg
      if (shift) then
        write (16, *) 'Reference and COG are independent', icg
      else
        write (16, *) 'Reference and COG coincide', icg
      end if
      do i = 1, ngood
        f(7, i) = f(7, i) + shifw
        gpai = f(7, i)/xmat
        bpai = sqrt(1.-1./(gpai*gpai))
        f(6, i) = f(6, i) + shtref
        vapi = vl*bpai
      end do
      if (itwiss==1) tref = tref + tofini
      write (16, *) ' After shift '
      bvref = vref/vl
      gamref = 1./sqrt(1.-bvref*bvref)
      wvref = (gamref-1.)*xmat
      write (16, 16) vref, tref, tref*deg, wvref, vshift, tshift, tshift*deg, eshift
16    format (2x, '  REFERENCE: VELOCITY :', e12.5, ' CM/SEC, T.O.F. :', e12.5, ' SEC  OR ', e12.5, ' DG', /, 3x, &
        ' ENERGY : ', e12.5, ' MeV', /, 2x, '  C.O.G.:    VELOCITY :', e12.5, ' CM/SEC, T.O.F. :', e12.5, ' SEC OR ', &
        e12.5, ' DG', /, 3x, ' ENERGY : ', e12.5, ' MeV', //)
      bpai = 0.
      do i = 1, ngood
        fo(7, i) = f(7, i)
        fo(2, i) = f(2, i)
        fo(3, i) = f(3, i)
        fo(4, i) = f(4, i)
        fo(5, i) = f(5, i)
        fo(6, i) = f(6, i)
      end do
      if (itwiss/=1) then
        write (11, *) ngood
        do i = 1, ngood
          f(2, i) = f(2, i) + centre(2)
          f(3, i) = f(3, i) + centre(3)
          f(4, i) = f(4, i) + centre(4)
          f(5, i) = f(5, i) + centre(5)
          f(6, i) = f(6, i) + centre(6)
          f(7, i) = f(7, i) + centre(1)
          etphas = fh*(f(6,i)-tcog)
          ! option          etener=f(7,i)-encog
          etener = f(7, i) - xmat
          write (11, 777) f(2, i), f(3, i), f(4, i), f(5, i), etphas, etener
        end do
777     format (6(f13.8,1x))
      end if
      ! ENVELOPE
      call stapl(davtot*10.)
      return
    end subroutine tiltbm_bis
    ! *******************************************************************
    ! SUBROUTINE accept
    ! computes a physical beam acceptance at the entrance of the machine
    ! *******************************************************************
    subroutine accept
      implicit real *8(a-h, o-z)
      parameter(iptsz=100002, maxcell=3000, maxcell1=3000)
      common /ttfc/tk, t1k, t2k, sk, s1k, s2k, fh
      common /tapes/in, ifile, meta
      common /faisc/f(10, iptsz), imax, ngood
      common /etcom/cog(8), exten(17), fd(iptsz)
      common /dyn/tref, vref
      common /dyni/vrefi, trefi, fhinit, acpt
      common /qmoyen/qmoy
      common /objet/fo(9, iptsz), imaxo
      common /consta/vl, pi, xmat, rpel, qst
      common /etcha1/dav2(maxcell1, 33), ichas(iptsz), chasit
      dimension back(9, iptsz)
      logical chasit, acpt
      common /mcs/imcs, ncstat, cstat(20)
      ! make statistics on initial beam using IEX at the point where
      ! the ACCEPT card has been placed
      write (16, *)
      write (16, *) 'Physical acceptance has:'
      write (16, *) imaxo, ' particles at origin'
      iprint = 1
      savfh = fh
      satref = tref
      savref = vref
      ! recall initial frequency
      fh = fhinit
      tref = trefi
      vref = vrefi
      ! save current beam
      do i = 1, 9
        do j = 1, ngood
          back(i, j) = f(i, j)
        end do
      end do
      ! original particle number is in f(1,j)
      ! F (I,8): =1 the particle is good,   =0 the particle is lost
      ! recuperate original particle numbers and their coordinates
      ! next loop for graphics and file of good particles
      do j = 1, imax
        tprt = fh*fo(6, j)
        eprt = fo(7, j) - xmat
        f2 = fo(2, j)
        f3 = fo(3, j)/1000.
        f4 = fo(4, j)
        f5 = fo(5, j)/1000.
        nold = int(f(1,j))
      end do
      open (23, file='input_kept.dst', status='unknown')
      dummy = 0.
      write (23, *) ngood, dummy, fh/(2000000.*pi)
      do j = 1, ngood
        nold = int(f(1,j))
        do jj = 1, 9
          f(jj, j) = fo(jj, nold)
        end do
        tprt = fh*f(6, j)
        eprt = f(7, j) - xmat
        f2 = f(2, j)
        f3 = f(3, j)
        f4 = f(4, j)
        f5 = f(5, j)
        if (ncstat>1) then
          write (23, 101) f2, f3/1000., f4, f5/1000., tprt, eprt, f(9, j)
        else
          write (23, 100) f2, f3/1000., f4, f5/1000., tprt, eprt
        end if
      end do
      close (23)
      ! now make graphics
      write (16, *) 'Starting good particles graphics for ACCEPT card'
      igrprm = 0
      call ytzp
      ! print out beam statistics
      call emiprt(0)
      ! next loop for graphics and file of lost particles
      open (23, file='input_lost.dst', status='unknown')
      dummy = 0.
      write (23, *) imax - ngood, dummy, fh/(2000000.*pi)
      j = 1
      ngd = ngood
      do k = ngood + 1, imax
        nold = int(f(1,k))
        do jj = 1, 9
          f(jj, j) = fo(jj, nold)
        end do
        tprt = fh*f(6, j)
        eprt = f(7, j) - xmat
        f2 = f(2, j)
        f3 = f(3, j)
        f4 = f(4, j)
        f5 = f(5, j)
        if (ncstat>1) then
          write (23, 101) f2, f3/1000., f4, f5/1000., tprt, eprt, f(9, j)
        else
          write (23, 100) f2, f3/1000., f4, f5/1000., tprt, eprt
        end if
        j = j + 1
      end do
      ngood = imax - ngood
100   format (6(f15.8,1x))
101   format (7(f15.8,1x))
      close (23)
      ! now make graphics
      write (16, *) 'Starting lost particles graphics for ACCEPT card'
      igrprm = 0
      call ytzp
      ! print out beam statistics
      call emiprt(0)
      ! recall original coordinates
      ngood = ngd
      do i = 1, 9
        do j = 1, ngood
          f(i, j) = back(i, j)
        end do
      end do
      tref = satref
      vref = savref
      fh = savfh
      return
    end subroutine accept
    ! *******************************************************************
    ! SUBROUTINE ytzp
    ! STORAGE OF PARTICLE COORDINATES FOR PLOTS
    ! *******************************************************************
    subroutine ytzp
      implicit real *8(a-h, o-z)
      parameter(iptsz=100002, maxcell=3000, maxcell1=3000)
      character *80 text, patitl
      common /consta/vl, pi, xmat, rpel, qst
      common /ttfc/tk, t1k, t2k, sk, s1k, s2k, fh
      common /faisc/f(10, iptsz), imax, ngood
      common /stis/suryth, surzph, enedep, ecogde, testca
      common /fene/wdisp, wphas, wx, wy, rlim, ifw
      common /dyn/tref, vref
      common /tapes/in, ifile, meta
      common /etcom/cog(8), exten(17), fd(iptsz)
      common /etcha1/dav2(maxcell1, 33), ichas(iptsz), chasit
      common /grparm/glim(4, 2), glim1(4, 2), glim2(4, 2), patitl, ngraphs(100), idwdp, igrprm, ngrafs
      common /mcs/imcs, ncstat, cstat(20)
      common /zones/frms(6), nzone
      logical chasit
      dimension oldcog(7), slim(4, 2)
      dimension xx(iptsz), yy(iptsz), cs(iptsz)

      satref = tref
      savref = vref
      init = 0
      call area(init)
      if (igrprm==0) then
        ! READ GRAPH TITLE
        read (in, 20) text
20      format (a)
        ! idwdp=0 cog=ref in ZZ' plot (for instance for Alvarez structure)
        ! idwdp=1 cog<>ref in ZZ' plot (for instance for IH structrure)
        read (in, *) idwdp, rmsmtp
        ! READ GRAPH LIMITS INTO GLIM(J,K), J=GRAPH NUMBER
        ! K=1 HOR. LIMIT , K=2 VERT. LIMIT
        read (in, *)((glim(j,k),k=1,2), j=1, 4)
      end if
      if (igrprm==1) then
        text = patitl
      end if
      if (igrprm==2) then
        text = patitl
        ! save limits in GLIM(j,k)
        do j = 1, 4
          do k = 1, 2
            slim(j, k) = glim(j, k)
            glim(j, k) = glim1(j, k)
          end do
        end do
      end if
      if (igrprm==3) then
        text = patitl
        ! save limits in GLIM(j,k)
        do j = 1, 4
          do k = 1, 2
            slim(j, k) = glim(j, k)
            glim(j, k) = glim2(j, k)
          end do
        end do
      end if
      do i = 1, ngood
        ichas(i) = 1
      end do
      iarg = 1
      call cdg(iarg)
      encog = cog(1)
      gcog = encog/xmat
      bcog = sqrt(1.-1./(gcog*gcog))
      tcog = cog(3)
      oldcog(1) = cog(4)
      oldcog(2) = cog(5)
      oldcog(3) = cog(6)
      oldcog(4) = cog(7)
      oldcog(5) = cog(3)
      oldcog(6) = cog(8)
      oldcog(7) = cog(1)
      enprt = encog - xmat
      teps = 1.e-08
      rmssz = sqrt(rmsmtp)
      iarg = 1
      call ext2(iarg)
      qdisp = rmssz*sqrt(exten(1))
      qmd = exten(1)*exten(3) - exten(2)*exten(2)
      qmdw = exten(10)*exten(3) - exten(11)*exten(11)
      surm = rmsmtp*180.*sqrt(qmd)
      qdp = rmssz*sqrt(exten(3))
      cor12 = exten(2)/sqrt(exten(1)*exten(3))
      pent12 = sqrt(exten(1)/exten(3))/cor12
      pent21 = sqrt(exten(1)/exten(3))*cor12
      qdpde = qdp*180./pi
      trqty = exten(4)*exten(5) - exten(8)*exten(8)
      trqpz = exten(6)*exten(7) - exten(9)*exten(9)
      suryth = rmsmtp*pi*sqrt(trqty)
      surzph = rmsmtp*pi*sqrt(trqpz)
      qditay = rmssz*sqrt(exten(4))
      qdiant = rmssz*sqrt(exten(5))
      qdita = rmssz*sqrt(exten(6))
      qdianp = rmssz*sqrt(exten(7))
      write (16, *) ' *** PLOT Ellips for ', rmsmtp, ' RMS'
      write (16, '(a)') text
      write (16, 1557) imax, ngood
1557  format (1x, ' *** GRAPH, TOTAL NUMBER OF PARTICLES : ', i6, ' PARTICLES KEPT : ', i6, //, &
        ' ***  HORIZONTAL phase plane ', /)
      write (16, 1553) cog(4), cog(5)
1553  format (4x, ' C.O.G. :', 5x, ' X : ', e12.5, ' CM  XP :', e12.5, ' MRD', /)
      if (rmsmtp>teps) then
        write (16, 1552) qditay, qdiant, suryth
1552    format (4x, ' 1/2 EXTENSION X : ', e12.5, ' CM', /, 4x, ' 1/2 EXTENSION XP : ', e12.5, ' MRD', 4x, &
          ' SURFACE : ', e15.8, ' CM.MRD', /)
      end if
      write (16, 1554)
1554  format (' ***  VERTICAL phase plane ', /)
      write (16, 1556) cog(6), cog(7)
1556  format (4x, ' C.O.G :', 5x, ' Y : ', e12.5, ' CM  YP :', e12.5, ' MRD', /)
      if (rmsmtp>teps) then
        write (16, 1555) qdita, qdianp, surzph
1555    format (4x, ' 1/2 EXTENSION Y : ', e12.5, ' CM', /, 4x, ' 1/2 EXTENSION YP : ', e12.5, ' MRD', 4x, &
          ' SURFACE : ', e15.8, ' CM.MRD', /)
      end if
      ! Store header and particle coordinates in binary file for
      ! graphics post-processor

      ! igrtyp is type of graph
      ! igrtyp=1  for ytzp emittance plots
      ! igrtyp=6  for ytzp emittance plots for multi-charge state beam
      ! igrtyp=11 for ytzp emittance plots with ZONES card

      igrtyp = 1
      if (nzone/=0) igrtyp = 11
      if (imcs==1) igrtyp = 6
      write (66, *) igrtyp
      if (igrtyp==6) then
        write (66, *) ncstat
        write (66, *)(cstat(j), j=1, ncstat)
      end if
      if (igrtyp==11) then
        write (66, *) nzone
        write (66, *)(frms(j), j=2, nzone), ' 0.'
      end if
      write (66, *) text
      xx(1) = glim(1, 1)
      yy(1) = glim(1, 2)
      write (66, *) - xx(1), xx(1), -yy(1), yy(1)
      ! first store ellips coordinates XX'
      step = qdiant/50.
      tta = exten(5)
      do i = 1, 101
        xii = -qdiant + step*float(i-1)
        yy(i) = xii + cog(5)
        yy(202-i) = yy(i)
        ttb = exten(8)*xii
        ttc = exten(4)*xii**2 - trqty*rmsmtp
        ttcb = ttb**2 - ttc*tta
        if (ttcb<=0.) ttcb = 0.
        if (tta==0.) then
          yi = 0.
          yii = 0.
        else
          quot = ttcb/tta**2
          yi = ttb/tta - sqrt(quot)
          yii = ttb/tta + sqrt(quot)
        end if
        xx(i) = yi + cog(4)
        xx(202-i) = yii + cog(4)
      end do
      do i = 1, 201
        write (66, *) xx(i), yy(i)
      end do
      do i = 1, ngood
        xx(i) = f(2, i)
        yy(i) = f(3, i)
      end do
      if (imcs==1) then
        do i = 1, ngood
          cs(i) = f(9, i)
        end do
      end if
      ! write particle coordinates to graphics file
      write (66, *) ngood
      if (imcs==0) then
        if (nzone==0) then
          do i = 1, ngood
            write (66, *) xx(i), yy(i)
          end do
        else
          do i = 1, ngood
            write (66, *) xx(i), yy(i), f(10, i)
          end do
        end if
      else
        do i = 1, ngood
          write (66, *) xx(i), yy(i), cs(i)
        end do
      end if
      ! YY' next
      xx(1) = glim(2, 1)
      yy(1) = glim(2, 2)
      write (66, *) - xx(1), xx(1), -yy(1), yy(1)
      ! first write ellips coordinates
      step = qdianp/50.
      tta = exten(7)
      do i = 1, 101
        xii = -qdianp + step*float(i-1)
        yy(i) = xii + cog(7)
        yy(202-i) = yy(i)
        ttb = exten(9)*xii
        ttc = exten(6)*xii**2 - trqpz*rmsmtp
        ttcb = ttb**2 - ttc*tta
        if (ttcb<=0.) ttcb = 0.
        if (tta==0.) then
          yi = 0.
          yii = 0.
        else
          quot = ttcb/tta**2
          yi = ttb/tta - sqrt(quot)
          yii = ttb/tta + sqrt(quot)
        end if
        xx(i) = yi + cog(6)
        xx(202-i) = yii + cog(6)
      end do
      do i = 1, 201
        write (66, *) xx(i), yy(i)
      end do
      do i = 1, ngood
        xx(i) = f(4, i)
        yy(i) = f(5, i)
      end do
      ! write particle coordinates to graphics file
      write (66, *) ngood
      if (imcs==0) then
        if (nzone==0) then
          do i = 1, ngood
            write (66, *) xx(i), yy(i)
          end do
        else
          do i = 1, ngood
            write (66, *) xx(i), yy(i), f(10, i)
          end do
        end if
      else
        do i = 1, ngood
          write (66, *) xx(i), yy(i), cs(i)
        end do
      end if

      ! TRACE GRAPHE ZZ'
      xx(1) = glim(3, 1)
      yy(1) = glim(3, 2)
      write (66, *) - xx(1), xx(1), -yy(1), yy(1)

      xx(1) = glim(4, 1)
      yy(1) = glim(4, 2)
      write (66, *) - xx(1), xx(1), -yy(1), yy(1)
      ! TRACE DE L ELLIPSE  DE CONCENTRATION
      bref = vref/vl
      gref = 1./sqrt(1.-bref*bref)
      wref = xmat*(gref-1.)
      gcog = 1./sqrt(1.-bcog*bcog)
      wcog = xmat*(gcog-1.)
      write (16, 22) wref, tref, wcog, tcog
22    format (' *** LONGITUDINAL phase plane ', /, 6x, ' REFERENCE : ', ' ENERGY: ', e15.8, ' (MeV), TOF: ', e15.8, &
        ' (SEC)', /, 6x, ' COG       : ', ' ENERGY: ', e15.8, ' (MeV), TOF: ', e15.8, ' (SEC)', /)
      write (16, 167) qmd, surm, qdp, qdpde, qdisp, cor12, pent12, pent21
167   format (3x, ' ***', ' 2nd ORDER MOMENTS :', e12.5, ' (RD DP/P)**2', '    SURFACE : ', e12.5, ' (DEG DP/P)', /, 6x, &
        ' 1/2 EXTENSION PHASE : ', e12.5, ' RD ', ' OR ', e12.5, ' DEG', /, 6x, ' 1/2 EXTENSION DISPERSION : ', e15.8, &
        ' IN DP/P ', /, 6x, ' CORRELATION COEF : ', e15.8, /, 6x, ' DISPERSION SLOPE: ', e15.8, ' (DP/P)/RD ', /, 6x, &
        ' PHASE SLOPE : ', e15.8, ' (DP/P)/RD ')
      ! GRAPHE DE L ELLIPSE
      step = qdpde/50.
      tta = exten(3)*180.*180./(pi*pi)
      do i = 1, 101
        xii = -qdpde + step*float(i-1)
        xx(i) = xii
        xx(202-i) = xx(i)
        ttb = exten(11)*xii*180./pi
        ttc = exten(10)*xii**2 - qmdw*rmsmtp*180.*180./(pi*pi)
        ttcb = ttb**2 - ttc*tta
        if (ttcb<=0.) ttcb = 0.
        if (tta==0.) then
          yi = 0.
          yii = 0.
        else
          quot = ttcb/tta**2
          yi = ttb/tta - sqrt(quot)
          yii = ttb/tta + sqrt(quot)
        end if
        yy(i) = yi
        yy(202-i) = yii
      end do
      enihrf = 0.
      if (idwdp==0) then
        ! Alvarez
        do i = 1, 201
          write (66, *) xx(i), yy(i)
        end do
      else
        ! IH
        bref = vref/vl
        gref = 1./sqrt(1.-bref*bref)
        enihrf = xmat*(gref-1.)
        phihrf = fh*(tcog-tref)*180./pi
        do i = 1, 201
          axx = phihrf
          ayy = encog - enihrf - xmat
          write (66, *) xx(i) + axx, yy(i) + ayy
        end do
      end if
      ! write particle coordinates to graphics file
      do i = 1, ngood
        if (idwdp==0) then
          ! Alvarez like
          xx(i) = fh*(f(6,i)-tcog)*180./pi
          yy(i) = f(7, i) - encog
          if (imcs==1) cs(i) = f(9, i)
        end if
        if (idwdp==1) then
          ! IH like
          xx(i) = fh*(f(6,i)-tref)*180./pi
          yy(i) = f(7, i) - enihrf - xmat
          if (imcs==1) cs(i) = f(9, i)
        end if
      end do
      ! write particle coordinates to graphics file
      write (66, *) ngood
      if (imcs==0) then
        if (nzone==0) then
          do i = 1, ngood
            write (66, *) xx(i), yy(i)
          end do
        else
          do i = 1, ngood
            write (66, *) xx(i), yy(i), f(10, i)
          end do
        end if
      else
        do i = 1, ngood
          write (66, *) xx(i), yy(i), cs(i)
        end do
      end if
      ! plot emittance  with chase (if applicable)
      ! if (chasit) call ytzprc(glim,oldcog,idwdp)
      if (igrprm==2 .or. igrprm==3) then
        ! restore limits in GLIM(j,k)
        do j = 1, 4
          do k = 1, 2
            glim(j, k) = slim(j, k)
          end do
        end do
      end if
      tref = satref
      vref = savref
      return
    end subroutine ytzp
    ! *******************************************************************
    ! SUBROUTINE grcomp(text,iskale)
    ! routine for plots
    ! *******************************************************************
    subroutine grcomp(text, iskale)
      implicit real *8(a-h, o-z)
      parameter(iptsz=100002, maxcell=3000, maxcell1=3000)
      character *80 text, patitl
      common /ttfc/tk, t1k, t2k, sk, s1k, s2k, fh
      common /faisc/f(10, iptsz), imax, ngood
      common /stis/suryth, surzph, enedep, ecogde, testca
      common /fene/wdisp, wphas, wx, wy, rlim, ifw
      common /consta/vl, pi, xmat, rpel, qst
      common /dyn/tref, vref
      common /tapes/in, ifile, meta
      common /etcom/cog(8), exten(17), fd(iptsz)
      common /etcha1/dav2(maxcell1, 33), ichas(iptsz), chasit
      common /grparm/glim(4, 2), glim1(4, 2), glim2(4, 2), patitl, ngraphs(100), idwdp, igrprm, ngrafs
      common /mcs/imcs, ncstat, cstat(20)
      common /zones/frms(6), nzone
      common /hist/xpos(200), xn(200), ypos(200), yn(200), zpos(200), zn(200), ixt, iyt, izt
      common /hist1/xps(200), xpn(200), yps(200), ypn(200), zps(200), zpn(200), ixpt, iypt, izpt
      logical chasit
      dimension xx(iptsz), yy(iptsz), cs(iptsz)
      dimension slim(4, 2)

      tcog = 0.
      do i = 1, ngood
        tcog = f(6, i) + tcog
      end do
      tcog = tcog/float(ngood)
      if (igrprm==1) then
        text = patitl
      end if
      if (igrprm==2) then
        text = patitl
        ! save limits in GLIM(j,k)
        do j = 1, 4
          do k = 1, 2
            slim(j, k) = glim(j, k)
            glim(j, k) = glim1(j, k)
          end do
        end do
      end if
      if (igrprm==3) then
        text = patitl
        ! save limits in GLIM(j,k)
        do j = 1, 4
          do k = 1, 2
            slim(j, k) = glim(j, k)
            glim(j, k) = glim2(j, k)
          end do
        end do
      end if
      write (16, *)
      write (16, *) 'LIMITS', ((glim(j,k),k=1,2), j=1, 4)
      ! X-Z start
      xyliz = glim(4, 1)*vref*pi/(180.*fh)
      zlix = xyliz
      xlix = glim(3, 1)
      dstrly = glim(4, 2)

      ! Store header and particle coordinates in binary file for
      ! graphics post-processor

      ! igrtyp is type of graph
      ! igrtyp=2  for grcomp extra plots
      ! igrtyp=7  for grcomp extra plots with multi charge state beam
      ! igrtyp=12 for grcomp extra plots with ZONES card
      igrtyp = 2
      if (nzone/=0) igrtyp = 12
      if (imcs==1) igrtyp = 7
      ! igrtyp=2,7,12   --> normal scale in envelopes
      ! igrtyp=17,22,27 --> log    scale in envelopes
      if (iskale==1) then
        write (66, *) igrtyp + 15
        write (66, *) dstrly
      else
        write (66, *) igrtyp
      end if
      if (igrtyp==7) then
        write (66, *) ncstat
        write (66, *)(cstat(j), j=1, ncstat)
      end if
      if (igrtyp==12) then
        write (66, *) nzone
        write (66, *)(frms(j), j=2, nzone), ' 0.'
      end if
      write (66, *) text
      ! new
      xx(1) = zlix
      yy(1) = xlix
      write (66, *) - xx(1), xx(1), -yy(1), yy(1)
      ! 120    CONTINUE
      if (imcs==1) then
        do i = 1, ngood
          cs(i) = f(9, i)
        end do
      end if
      if (idwdp==0) then
        ! Alvarez type (plot w.r.t. reference)
        do i = 1, ngood
          gpai = f(7, i)/xmat
          bpai = sqrt(1.-1./(gpai*gpai))
          xx(i) = (tcog-f(6,i))*vl*bpai
          yy(i) = f(2, i)
        end do
      else
        ! IH type (plot w.r.t. centre of gravity)
        do i = 1, ngood
          gpai = f(7, i)/xmat
          bpai = sqrt(1.-1./(gpai*gpai))
          xx(i) = (tref-f(6,i))*vl*bpai
          yy(i) = f(2, i)
        end do
      end if
      ! write particle coordinates to graphics file
      write (66, *) ngood
      if (imcs==0) then
        if (nzone==0) then
          do i = 1, ngood
            write (66, *) xx(i), yy(i)
          end do
        else
          do i = 1, ngood
            write (66, *) xx(i), yy(i), f(10, i)
          end do
        end if
      else
        do i = 1, ngood
          write (66, *) xx(i), yy(i), cs(i)
        end do
      end if
      ! Y-Z start
      zliy = xyliz
      zliy = glim(3, 2)
      xx(1) = zlix
      yy(1) = zliy
      write (66, *) - xx(1), xx(1), -yy(1), yy(1)
      ! 1200   CONTINUE
      if (idwdp==0) then
        ! Alvarez type (plot w.r.t. reference)
        do i = 1, ngood
          gpai = f(7, i)/xmat
          bpai = sqrt(1.-1./(gpai*gpai))
          xx(i) = (tcog-f(6,i))*vl*bpai
          yy(i) = f(4, i)
        end do
      else
        ! IH type (plot w.r.t. centre of gravity)
        do i = 1, ngood
          gpai = f(7, i)/xmat
          bpai = sqrt(1.-1./(gpai*gpai))
          xx(i) = (tref-f(6,i))*vl*bpai
          yy(i) = f(4, i)
        end do
      end if
      ! write particle coordinates to graphics file
      write (66, *) ngood
      if (imcs==0) then
        if (nzone==0) then
          do i = 1, ngood
            write (66, *) xx(i), yy(i)
          end do
        else
          do i = 1, ngood
            write (66, *) xx(i), yy(i), f(10, i)
          end do
        end if
      else
        do i = 1, ngood
          write (66, *) xx(i), yy(i), cs(i)
        end do
      end if
      ! 1400   CONTINUE
      ! beam profile plots for X,Y & Z
      call histgrm
      write (66, *) ixt
      do i = 1, ixt
        write (66, *) xpos(i), xn(i)
      end do
      write (66, *) iyt
      do i = 1, iyt
        write (66, *) ypos(i), yn(i)
      end do
      write (66, *) izt
      do i = 1, izt
        write (66, *) zpos(i), zn(i)
      end do
      ! beam profile plots for Xp,Yp & Zp
      write (66, *) ixpt
      do i = 1, ixpt
        write (66, *) xps(i), xpn(i)
      end do
      write (66, *) iypt
      do i = 1, iypt
        write (66, *) yps(i), ypn(i)
      end do
      write (66, *) izpt
      do i = 1, izpt
        write (66, *) zps(i), zpn(i)
      end do
      if (igrprm==2 .or. igrprm==3) then
        ! restore limits in GLIM(j,k)
        do j = 1, 4
          do k = 1, 2
            glim(j, k) = slim(j, k)
          end do
        end do
      end if
      return
    end subroutine grcomp
    ! *******************************************************************
    ! SUBROUTINE restay
    ! motion of particles in a cavity
    ! the field can be read from disk in the form (z,E(z)) or it can be
    ! listed in the form of a Fourier series expansion
    ! *******************************************************************
    subroutine restay
      implicit real *8(a-h, o-z)
      ! ****************************************************
      parameter(iptsz=100002, maxcell=3000, maxcell1=3000)
      common /ttfs/dynt(maxcell), dyntp(maxcell), dyntpp(maxcell), dyne0(maxcell), dynph(maxcell), dynlg(maxcell), &
        fhpar, nc
      common /posi/ist
      common /midgap/enmil, vapmi
      common /azmtch/dlg, xmcph, xmce
      common /azlist/icont, iprin
      common /itvole/itvol, imamin
      common /func/a(200), ylg, atte, ncel, nharm
      ! TRANSIT TIME COEFFICIENTS
      common /ttfc/tk, t1k, t2k, sk, s1k, s2k, fh
      common /ttfcb/t3k, t4k, s3k, s4k
      common /bedycp/phslip, eqvl, asdl, peqvl, pavph, xkp1, xkp2, aa, bb, cc, dd, ee, pcrest, sqcttf
      common /jacob/gaks, gaps
      common /iter1/dxdki, dphii, phi, dkmske, dkmsphi, retph, xkmi, xkm, dxk00, tke, t1ke, ske, s1ke, phiwc, xk1i, &
        xk1ii, xk2ii
      common /faisc/f(10, iptsz), imax, ngood
      common /cell/yf(10000), xf(10000), xlim(15), flength, fhc, att, npoint(15), ncell
      common /rfield/ifield
      common /qmoyen/qmoy
      common /rigid/boro
      common /cdek/dwp(iptsz)
      common /sc3/beamc, scdist, sce10, cplm, ect, apl, ichaes, iscsp
      common /consta/vl, pi, xmat, rpel, qst
      common /dyn/tref, vref
      common /compt/nrres, nrtre, nrbunc, nrdbun
      common /compt1/ndtl, ncavmc, ncavnm
      common /fene/wdisp, wphas, wx, wy, rlim, ifw
      common /tapes/in, ifile, meta
      common /ranec1/dummy(6)
      common /etcom/cog(8), exten(17), fd(iptsz)
      common /speda/dave, idave
      common /shif/dtiph, shift
      common /davcom/dav1(maxcell1, 40), davtot, iitem(maxcell1), idav
      common /etcha1/dav2(maxcell1, 33), ichas(iptsz), chasit
      common /dcspa/iesp
      common /pltprf/sprfx(3000), sprfy(3000), sprfl(3000), sprfw(3000), sprfp(3000), sprng(3000), iprf
      common /appel/irstay, ilost, iavp, ispcel
      common /posc/xpsc
      common /pstpla/tstp
      common /femt/iemgrw, iemqesg
      common /mode/eflvl, rflvl
      common /aerp/vphase, vfield, ierpf
      common /tofev/ttvols
      ! ****    reference
      ! ****     DWRFS(MeV): energy gain
      ! ****     SPHRFS(rad):phase jump
      ! ****     PHRFS(rad):phase
      ! ****       common/parmrf/DWRFS,SPHRFS,PHRFS,ngdrf
      logical iesp, ichaes, irstay, iavp, ispcel, ifield, iemgrw
      logical shift, chasit, itvol, imamin, dave
      character *1 cr
      ! ************************************************************
      ! XESLN : NEGATIVE LENGHT OF THE DRIFT FOLLOWING THE GAP
      ! IF XESLN N.E.0 THEN THE CHARGE SPACE EFFECT IMPLIES THE
      ! LENGTH (YLG-XESLN)
      nrres = nrres + 1
      ncavmc = ncavmc + 1
      ! allow for print out on terminal of gap# on one and the same line
      cr = char(13)
      write (6, 8254) nrtre, nrres, cr
8254  format ('Transport element:', i5, '      Accelerating element:', i5, a1, $)
      write (16, *) ' CAVITY N :', nrres
      ilost = 0
      aqst = abs(qst)
      qmoy = aqst
      ! --- the frequency fh may be changed with delfh
      oldfh = fh
      ! IDUM : dummy variable (indicate in input file the number of the cavity)
      read (in, *) idum

      ! --- XESLN (cm): difference between the length of the field YLG and the physical length of the cavity
      ! (The space charge is acting on the length (YLG-XESLN) )
      ! dphase (deg): phase offset from the phase crest (giving the maximum of energy gain)
      ! FFIELD : in percent;
      ! (electric field)=(initial electric field)*(1.+FFIELD/100)
      ! isec: flag
      ! isec = 0 : The crest phase (or the valley) is adjusted at the entrance of the accelerating element
      ! isec = 1 : The crest phase (or the valley)is adjusted at the middle of the accelerating element

      ! idum is for compatability with CAVNUM
      read (in, *) xesln, dphase, ffield, isec, idum
      ffield = 1. + ffield/100.
      if (ifield) then
        ! --- The field is read on the disk in file 'field.txt' in the form:
        ! z   (cm)   E(z) MV/cm
        ! fhc: frequency of the cavity (Hertz) (read in the file 'field.txt' )
        fh = fhc*2.*pi
        ncel = ncell
        atte = att
        ye0 = atte
        ! flength : length of the field (cm)
        ylg = flength
        scdist = ylg - abs(xesln)
      else
        ! --- The field is read in the input list in the form of a Fourier series
        oldfh = fh
        ! atte: factor acting on the amplitude of the field (read in the input list)
        ye0 = atte
        scdist = ylg - abs(xesln)
      end if
      dphete = dphase
      if (itvol .and. imamin) then
        ! ---  adjustment of the phase offset w.r.t. the t.o.f.  (deg)
        ottvol = fh*ttvols*180./pi
        attvol = ottvol
        xkpi = ottvol/360.
        ixkpi = int(xkpi)
        xkpi = (xkpi-float(ixkpi))*360.
        dphase = dphase - xkpi
      end if
      ! --- iesp, irstay and ispcel: logical flags for space charge computations
      iesp = .false.
      irstay = .true.
      ispcel = .true.
      ! ---  dwp(*): array reserved to space charge computations
      do i = 1, iptsz
        dwp(i) = 0.
      end do
      write (16, 150) fh/(2.*pi), ylg, atte, ffield, ncel
150   format (4x, 'FREQUENCY :', e12.5, ' Hertz', /, 4x, 'FIELD LENGTH :', e12.5, ' cm', /, 4x, &
        'FIELD FACTOR (UNITS CONVERSION) :', e12.5, /, 4x, 'FIELD FACTOR (ATTENUATION)      :', f12.6, /, 4x, &
        'FIELD DIVIDED IN: ', i4, ' SECTIONS ')
      if (.not. imamin) write (16, *) '    PHASE OFFSET: ', dphete, ' DEG'
      if (imamin) write (16, 1501) dphete, dphase, xkpi
1501  format (4x, 'PHASE OFFSET (before adjustment): ', e12.5, ' deg', /, 4x, 'PHASE OFFSET (after adjustment): ', &
        e12.5, ' deg', /, 4x, 'ADJUSTMENT ON THE PHASE OFFSET: ', e12.5, ' deg')
      beref = vref/vl
      fh0 = fh/vl
      ! --- prediction of transit time factors TK and SK  based on the velocity at the entrance
      tk = tta0(beref)/2.*ffield
      sk = tsb0(beref)/2.*ffield
      ! --- prediction of PCREST (phase of RF giving the maximum of energy gain in the cavity)
      pcrest = atan(-sk/tk)
      ddwc = aqst*(tk*cos(pcrest)-sk*sin(pcrest))
      if (ddwc<0.) pcrest = pcrest + pi
      ! --- ttvol: time of flight at entrance (sec)
      ttvol = 0.
      if (itvol) ttvol = ttvols*fh
      ! start file 'short.data'
      ! --- dav1(idav,3)=0: the particle reference and the cog coincide at the input
      ! --- dav1(idav,3)=1: the particle reference and the cog are independent
      dav1(idav, 3) = 0.
      idav = idav + 1
      iitem(idav) = 1
      dav1(idav, 1) = ylg*10.
      dav1(idav, 2) = ye0*100.
      tstp = (davtot+ylg*xpsc)*10.
      davtot = davtot + ylg
      dav1(idav, 24) = davtot*10.
      dav1(idav, 40) = fh
      if (iprf==1) call stapl(dav1(idav,24))
      iarg = 1
      call cdg(iarg)
      enold = cog(1)
      encog = enold
      gcog = enold/xmat
      bcog = sqrt(1.-1./(gcog*gcog))
      tcog = cog(3)
      if (shift) then
        ! --- the reference particle and the cog are independent
        beref = vref/vl
        gamref = 1./sqrt(1.-(beref*beref))
        enref = xmat*gamref
        trefdg = tref*fh*180./pi
        dav1(idav, 3) = 1.
      else
        ! --- the reference particle and the cog are coinciding
        beref = bcog
        vref = bcog*vl
        tref = tcog
        gamref = gcog
        enref = cog(1)
        dav1(idav, 3) = 0.
      end if
      ! ---   the reference particle is put in the array f(10,iptsz) at the position ngdrf = ngood + 1
      ! ****         ngdrf=ngood+1
      ! ****         BEREF=VREF/VL
      ! ****         GAMREF=1./SQRT(1.-(BEREF*BEREF))
      ! ****         ENREF=XMAT*GAMREF
      ! ****         f(1,ngdrf)=ngdrf
      ! ****         f(2,ngdrf)=0.
      ! ****         f(3,ngdrf)=0.
      ! ****         f(4,ngdrf)=0.
      ! ****         f(5,ngdrf)=0.
      ! ****         f(6,ngdrf)=tref
      ! ****         f(7,ngdrf)=enref
      ! ****         f(8,ngdrf)=1.
      ! ****         f(9,ngdrf)=qst
      ! ****         f(10,ngdrf)=0.
      if (dav1(idav,3)==1.) write (16, *) ' ****reference and cog evolve independently'
      if (dav1(idav,3)==0.) write (16, *) ' **** the reference is the cog '
      write (16, 178)
178   format (/, ' Dynamics at the input', /, 5x, '   BETA     GAMMA      ENERGY(MeV) ', '       TOF(deg)     TOF(sec)')
      write (16, 1788) bcog, gcog, encog - xmat, tcog*fh*180./pi, tcog
1788  format (' COG ', f7.5, 3x, e12.5, 1x, e12.5, 3x, e12.5, 3x, e12.5)
      enrprin = enref - xmat
      write (16, 165) beref, gamref, enrprin, tref*fh*180./pi, tref
165   format (' REF ', f7.5, 3x, e12.5, 1x, e12.5, 3x, e12.5, 3x, e12.5)
      tofprt = tref
      iprint = 0
      call statis
      xk1 = fh/vref
      ! --- prediction of transit time factors based on an average value of velocity
      ddw = aqst*(tk*cos(pcrest)-sk*sin(pcrest))
      enrefs = enref + ddw
      gams = enrefs/xmat
      bets = sqrt(1.-1./(gams*gams))
      bemy = (gams+gamref)/(gams*bets+gamref*beref)
      bemy = 1./bemy
      tk0 = tta0(bemy)/2.*ffield
      tpk0 = tta1(bemy)/2.*ffield
      tppk0 = tta2(bemy)/2.*ffield
      tp3k0 = tta3(bemy)/2.*ffield
      tp4k0 = tta4(bemy)/2.*ffield
      sk0 = tsb0(bemy)/2.*ffield
      spk0 = tsb1(bemy)/2.*ffield
      sppk0 = tsb2(bemy)/2.*ffield
      sp3k0 = tsb3(bemy)/2.*ffield
      sp4k0 = tsb4(bemy)/2.*ffield
      tk = tk0
      t1k = tpk0
      t2k = tppk0
      t3k = tp3k0
      t4k = tp4k0
      sk = sk0
      s1k = spk0
      s2k = sppk0
      s3k = sp3k0
      s4k = sp4k0
      ! ----  prediction of PCREST (crest phase) based on the actual coefficients factors T and S
      pcrest = atan(-sk0/tk0)
      ddwc = aqst*(tk*cos(pcrest)-sk*sin(pcrest))
      if (ddwc<0.) pcrest = pcrest + pi
      ! --- the routine crest is computing the equivalent field lenght: EQVL
      call crest(bemy, eqvl, xpos, sqcttf, ffield)
      ! ---  follow computations of the parameters:
      ! equivalent field length   (cm)
      ! asociated drift length    (cm)
      ! slip of phase             (rad)
      ! energy gain               (MeV)
      ! phase jump                (rad)
      ! average k (=frequency/velocity) (cm-1)
      ! transit time coefficients (MeV,cm)
      ! crest phase               (rd)
      ! phase of RF at entrance   (rd)
      saphi = pcrest
      ! --- start iterations: improve the average velocity and the transit time factors
      do it = 1, 3
        dts = (tk*t1k+sk*s1k)/(tk*tk+sk*sk)
        fk1 = 2.*dts
        eqvlp = eqvl
        ! --- computation of the phase slip: PHSLIP
        phslip = -4.*atan(3.2*dts/eqvl)
        if (phslip/=0.) then
          til2 = phslip/2.
          do iiii = 1, 4
            gx = 1./tan(til2) - 1./til2 - fk1/eqvlp
            gpx = -1./(sin(til2)*sin(til2)) + 1./(til2*til2)
            til2 = til2 - gx/gpx
            hx = 1./tan(til2) - 1./til2
            eqvlp = fk1/hx
          end do
          phslip = til2*2.
        end if
        peqvl = xpos
        asdl = peqvl - eqvl/2.
        f0 = xitl0(gamref, gams, bemy, saphi, aqst)
        delwrm = (f0-gamref)*xmat
        enrs = enref + delwrm
        gams = enrs/xmat
        bets = sqrt(1.-1./(gams*gams))
        ! ---  computation of the jump of phase:DELPHR
        coeph = fh*aqst/(vl*xmat)
        f3 = xitl3(gamref, gams, bemy, it, saphi, aqst)
        delphr = coeph*f3
        xk2 = fh0/bets
        xkm = delphr/eqvl + xk2*(1.+asdl/eqvl) - xk1*asdl/eqvl
        bemy = fh0/xkm
        ! --- computations of transit time factors
        tk = tta0(bemy)/2.*ffield
        t1k = tta1(bemy)/2.*ffield
        sk = tsb0(bemy)/2.*ffield
        s1k = tsb1(bemy)/2.*ffield
      end do
      ! --- crest phase PCREST (after iterations)
      pcrest = atan(-sk/tk)
      ddwc = aqst*(tk*cos(pcrest)-sk*sin(pcrest))
      if (ddwc<0.) pcrest = pcrest + pi
      dcemd = 0.
      ! --- isec = 0: the phase offset is given relative to the entrance of the cavity
      ! --- isec = 1: the phase offset is given relative to the middle of the cavity
      ! --- (vapmi has been computed in the function XITL3 (in deg) )
      if (isec/=0) then
        imedi = int(vapmi/360.+.4)
        dcemd = vapmi - 360.*imedi
        write (16, 773) nrres, enmil, vapmi, dcemd
773     format (2x, ' AT THE MIDDLE OF THE CAVITY:', i4, /, 2x, ' *ENERGY :', e12.5, ' MEV  *PHASE :', e12.5, ' DEG', &
          2x, ' *SLIP OF PHASE  :', e12.5, ' deg', /)
        dcemd = dcemd*pi/180.
      end if
      ! SAPHI: phase of RF w.r.t. the phase offset
      dphase = dphase*pi/180.
      saphi = pcrest + dphase + ttvol - dcemd
      ddw = aqst*(tk0*cos(saphi)-sk0*sin(saphi))
      enrs = enref + ddw
      gams = enrs/xmat
      ! --- start new iterations to improve:
      ! transit time factors
      ! phase slip
      ! jump of phase
      ! crest phase
      ! phase of RF

      sapho = saphi
      do it = 1, 3
        dts = (tk*t1k+sk*s1k)/(tk*tk+sk*sk)
        fk1 = 2.*dts
        eqvlp = eqvl
        phslip = -4.*atan(3.2*dts/eqvl)
        if (phslip/=0.) then
          til2 = phslip/2.
          do iiii = 1, 3
            gx = 1./tan(til2) - 1./til2 - fk1/eqvlp
            gpx = -1./(sin(til2)*sin(til2)) + 1./(til2*til2)
            til2 = til2 - gx/gpx
            hx = 1./tan(til2) - 1./til2
            eqvlp = fk1/hx
          end do
          phslip = til2*2.
        end if
        peqvl = xpos
        asdl = peqvl - eqvl/2.
        ! --- ENERGY GAIN AND PHASE JUMP
        f0 = xitl0(gamref, gams, bemy, saphi, aqst)
        delwrm = (f0-gamref)*xmat
        enrs = enref + delwrm
        gams = enrs/xmat
        bets = sqrt(1.-1./(gams*gams))
        xk2 = fh0/bets
        ! ---    DELPHR: jump of phase
        coeph = fh*aqst/(vl*xmat)
        f2 = xitl3(gamref, gams, bemy, it, saphi, aqst)
        delphr = coeph*f2
        ! ---   XKM:  average k =  frequency/velocity)
        xkm = delphr/eqvl + xk2*(1.+asdl/eqvl) - xk1*asdl/eqvl
        bemy = fh0/xkm
        ! ---  TRANSIT TIME FACTORS (based on the velocity BEMY)
        tk = tta0(bemy)/2.*ffield
        t1k = tta1(bemy)/2.*ffield
        t2k = tta2(bemy)/2.*ffield
        t3k = tta3(bemy)/2.*ffield
        t4k = tta4(bemy)/2.*ffield
        sk = tsb0(bemy)/2.*ffield
        s1k = tsb1(bemy)/2.*ffield
        s2k = tsb2(bemy)/2.*ffield
        s3k = tsb3(bemy)/2.*ffield
        s4k = tsb4(bemy)/2.*ffield
        pcrest = atan(-sk/tk)
        ddwc = aqst*(tk*cos(pcrest)-sk*sin(pcrest))
        if (ddwc<0.) pcrest = pcrest + pi
        dphii = (xk1-xk2)*eqvl/10. + (xkp1+xkp2)/120.*eqvl*eqvl + (xk1-xkm)*asdl
        ! --- phase of RF
        ! *2011*July*16 DPHII sign
        ! *2011 SV        SAPHI=PCREST+DPHASE+TTVOL-DCEMD+DPHII
        ! *2011 ET        SAPHI=PCREST+DPHASE+TTVOL-DCEMD-DPHII
        saphi = pcrest + dphase + ttvol - dcemd + dphii
      end do
      savph = saphi*180./pi
      ! REFERENCE PARTICLE BASED ON CHARGE STATE: QMOY = ABS(QST)
      cfh = fh/(vl*2.*xmat)
      ckh = qmoy*qmoy/(4.*xmat*xmat)
      dphii = (xk1-xk2)*eqvl/10. + (xkp1+xkp2)/120.*eqvl*eqvl + (xk1-xkm)*asdl
      phares = saphi + xk2*ylg + delphr
      ! ***** TEST
      ! DITEMP=(2.*XK1*ASDL+XKM*(EQVL-ASDL)+
      ! x        XK2*(YLG-(EQVL+ASDL)))/FH+DELPHR/FH
      ! cc       DITEMP=(XK1*ASDL+XKM*(EQVL)+
      ! cc     x        XK2*(YLG-(EQVL+ASDL)))/FH+DELPHR/FH
      trefs = tref + (xk2*ylg+delphr)/fh
      ! cc       TREFS1=TREF+DITEMP
      ! cc       write(6,*) 'trefs trefs1 ',trefs,trefs1
      ! cc       pause
      ! ****************************
      phared = (phares-saphi)*180./pi
      tredg = fh*trefs*180./pi
      ! ******  REFERENCE BASED ON THE AVERAGE CHARGE STATE QMOY (if several charges state)
      ! *******       CFH=FH/(VL*2.*XMAT)
      ! ******       CKH=QMOY*QMOY/(4.*XMAT*XMAT)
      ! ******  save the energy and the T.O.F of the particle reference at the input of the cavity
      ! ******       enri=f(7,ngdrf)
      ! *****       trefi=f(6,ngdrf)
      ! *****       call gap(gamref,saphi,gams,delphr)
      ! ***** trefs and enrs: time of flight and energy of the reference and the output of the cavity
      ! *****       trefs=f(6,ngdrf)
      ! *****       enrs=f(7,ngdrf)
      ! *****       grefs=f(7,ngdrf)/xmat
      ! *****       bets=sqrt(grefs*grefs-1.)/grefs
      ! *****       dwrfs=enrs-enri
      ! *****       PHARES=SAPHI+XK2*YLG+DELPHR
      ! *****       TREFS=TREF+(XK2*YLG+DELPHR)/FH
      ! *****       TREDG=fh*TREFS *180./PI
      write (16, *) ' PARAMETERS RELATING TO THE REFERENCE PARTICLE '
      write (16, *) '***********************************************'
      write (16, *) ' ENERGY GAIN(MeV) ', delwrm, ' TOF ', tredg, ' DEG'
      write (16, *) ' PHASE JUMP(DG) ', delphr*180./pi
      write (16, *) ' SLIP OF PHASE AT THE INPUT(DG) ', sapho*180./pi
      write (16, *) ' PHASE OF RF AT ENTRANCE(DG) ', savph
      write (16, *) ' AVERAGE k (cm-1) (freq./velocity): ', xkm
      write (16, *) ' Associated drift length ', asdl, ' (cm)'
      write (16, *) ' Equivalent field length ', eqvl, ' cm center at ', xpos, ' cm'
      write (16, *) ' TRANSIT TIME FACTORS AND DERIVATIVES (MeV,cm):'
      write (16, *) ' T ', tk, t1k, t2k, t3k, t4k
      write (16, *) ' S ', sk, s1k, s2k, s3k, s4k
      write (16, *) ' PHASE SLIP(DEG) ', phslip*180./pi
      write (16, *) ' CREST PHASE OF RF (DEG) ', pcrest*180./pi
      write (16, *) ' MAGNITUDE ', sqcttf, ' MV/cm'
      t0s = sqrt(tk*tk+sk*sk)
      write (16, *) ' T0 ', t0s
      ! *************************************************************************
      call gap(gamref, saphi, gams, delphr)
      iarg = 1
      call cdg(iarg)
      encog = cog(1)
      gcog = encog/xmat
      bcog = sqrt(1.-1./(gcog*gcog))
      tcog = cog(3)
      call ext2d(1)
      ! print in file 'short.data'
      ! 3.12.09       phnew=-(int(tcog*fh/pi+0.5)-tcog*fh/pi)*180.
      ! 3.12.09       dav1(idav,6)=encog-xmat
      ! 3.12.09        dav1(idav,7)=phnew
      if (itvol) then
        dav1(idav, 38) = dphete
        dav1(idav, 39) = dphase*180./pi
      else
        dav1(idav, 38) = dphete
      end if
      write (16, 3777)
3777  format (/, ' Dynamics at the output', /, 5x, '   BETA     dW(MeV)     ENERGY(MeV) ', '   TOF(deg)     TOF(sec)')
      engain = encog - enold
      write (16, 3473) bets, delwrm, enrs - xmat, fh*trefs*180./pi, trefs
3473  format (' REF ', f7.5, 3x, f10.6, 3x, e12.5, 3x, e12.5, 3x, e12.5)
      write (16, 1789) bcog, engain, encog - xmat, tcog*fh*180./pi, tcog
1789  format (' COG ', f7.5, 3x, f10.6, 3x, e12.5, 3x, e12.5, 3x, e12.5)
      testca = exten(1)*exten(2)*exten(3)
      ! epsil=1.E-20
      epsil = 1.e-40
      if (abs(testca)>epsil) then
        qdisp = 2.*sqrt(exten(1))
        qmd = exten(1)*exten(3) - exten(2)**2
        sqmdv = 4.*pi*sqrt(qmd)
        surm = 4.*pi*sqrt(qmd)*180./pi
        qdp = 2.*sqrt(exten(3))
        cor12 = exten(2)/sqrt(exten(1)*exten(3))
        ! omment         PENT12=SQRT(exten(1)/exten(3))/COR12
        ! omment         PENT21=SQRT(exten(1)/exten(3))*COR12
        qdpde = qdp*180./pi
      else
        qdisp = 0.
        qmd = 0.
        sqmdv = 0.
        surm = 0.
        qdp = 0.
        cor12 = 0.
        pent12 = 0.
        pent21 = 0.
        qdpde = 0.
      end if
      trqtx = exten(4)*exten(5) - exten(8)**2
      trqpy = exten(6)*exten(7) - exten(9)**2
      qditax = 2.*sqrt(exten(4))
      qdiant = 2.*sqrt(exten(5))
      qditay = 2.*sqrt(exten(6))
      qdianp = 2.*sqrt(exten(7))
      surxth = 4.*pi*sqrt(trqtx)
      suryph = 4.*pi*sqrt(trqpy)
      if (shift) then
        vref = bets*vl
        tref = trefs
      else
        vref = bcog*vl
        tref = tcog
      end if
      if (itvol) then
        ttvols = tref
        ! omment        dphete=dgphr
        ! omment        attvol=fh*ttvols*180./pi
        ! omment        write(16,7456) ottvol,attvol
      end if
      ! omment 7456   format(2x,'***tof at the input: ',e12.5,' deg',/,
      ! omment     *           2x,'***tof at the output: ',e12.5,' deg')
      call statis
      ! ENVEL
      call stapl(dav1(idav,24))
      ! omment       WRITE(16,9998) SQMDV
      ! omment9998   FORMAT(2X,'   EMITTANCE (norm): ',
      ! omment     *        E12.5,' PI*MEV*RAD')
      dav1(idav, 16) = bcog*surxth*10./(pi*sqrt(1.-bcog*bcog))
      ! 3.12.09       dav1(idav,17)=surxth*10./pi

      dav1(idav, 21) = bcog*suryph*10./(pi*sqrt(1.-bcog*bcog))
      dav1(idav, 25) = nrres
      dav1(idav, 30) = ngood

      ! print in the file: 'dynac.dmp':
      ! gap number, phase offset(deg), relativistic beta, energy(MeV), horz. emit.(mm*mrd,norm), vert.
      ! emit.(mm*mrd,norm),long. emit(keV*sec)

      ! --- dav1(idav,16): Emittance(norm)  x-xp (mm*mrad)
      ! --- dav1(idav,21): Emittance(norm)  y-yp (mm*mrad)
      emns = 1.e12*sqmdv/(pi*fh)
      ! et2010s
      tcgprt = fh*tcog*180./pi
      trfprt = fh*tref*180./pi
      ! cavity number, z (m), transmission (%), synchronous phase (deg), time of flight (deg) (reference),
      ! COG relativistic beta (@ output), COG output energy (MeV), REF relativistic beta (@ output), REF output energy
      ! (MeV),
      ! horizontal emittance (mm.mrad, RMS normalized), vertical emittance (mm.mrad, RMS normalized),
      ! longitudinal emittance (RMS, ns.keV)
      trnsms = 100.*float(ngood)/float(imax)
      if (ncavmc==1) write (50, *) '# cavmc.dmp'
      if (ncavmc==1) write (50, *) '# cav     Z       trans   ', &
        'PHIs     TOF(COG)    COG        Wcog          TOF(REF)   ', &
        '    REF        Wref       Ex,RMS,n     Ey,RMS,n     El,RMS'
      if (ncavmc==1) write (50, *) '#  #     (m)       (%)    ', &
        '(deg)     (deg)      beta       (MeV)          (deg)      ', &
        '   beta       (MeV)      (mm.mrad)    (mm.mrad)    (ns.keV)'
      write (50, 7023) nrres, 0.001*dav1(idav, 24), trnsms, dphete, tcgprt, bcog, encog - xmat, trfprt, bets, &
        enrs - xmat, 0.25*dav1(idav, 16), 0.25*dav1(idav, 21), 0.25*emns
7023  format (1x, i4, 1x, e12.5, 1x, f6.2, 1x, f7.2, 1x, 2(e14.7,1x,f7.5,1x,e14.7,1x), 3(e12.5,1x))
      ! et2010e
      fh = oldfh
      ! new magnetic rigidity of the reference
      gref = 1./sqrt(1.-bets*bets)
      xmor = xmat*bets*gref
      boro = 33.356*xmor*1.e-01/aqst
      write (16, *) ilost, ' particles lost in cavity ', nrres
      call emiprt(0)
      return
    end subroutine restay
    ! *******************************************************************
    ! SUBROUTINE fieldcav(atte)
    ! read from disk the electromagnetic field in the form (z,E(z))
    ! SUPERFISH units: z(m) E(z) (Volt/m)
    ! converted to: z(cm)  E(z) (MVolt/cm)
    ! *******************************************************************
    subroutine fieldcav(atte)
      implicit real *8(a-h, o-z)
      common /consta/vl, pi, xmat, rpel, qst
      common /rfield/ifield
      common /cell/yf(10000), xf(10000), xlim(15), flength, fhc, att, npoint(15), ncell
      common /spl/xspl(4000), yspl(4000), s(5000), p(5000), q(5000)
      common /mode/eflvl, rflvl
      common /cavnum1/xnh, xpas, ffield, npt
      common /kcell/avrg(15)
      logical ifield

      part = 1.
      ifield = .true.
      read (20, *) fhc
      ! nov02       att=att*(1.+eflvl)
      att = atte
      read (20, *) xspl(1), yspl(1)
      yspl(1) = yspl(1)*att
      xspl(1) = xspl(1)*100.
      npt = 2
      do i = 2, 4000
        read (20, *) xspl(i), yspl(i)
        if (xspl(i)==0.) go to 10
        xspl(i) = xspl(i)*100.
        yspl(i) = yspl(i)*att
        npt = npt + 1
      end do
10    continue
      npt = npt - 1
      ! **************************************
      tdep = xspl(1)
      do it = 1, npt
        xspl(it) = xspl(it) - tdep
      end do
      ! **************************************
      call deriv2(npt)
      xpas = (xspl(3)-xspl(2))/part
      xcour = xspl(1)
      nfpt = 1
      do i = 1, 10000
        if (xcour>xspl(npt)) go to 20
        yf(i) = spline(npt, xcour)
        xf(i) = xcour
        xcour = xcour + xpas
        nfpt = nfpt + 1
      end do
20    continue
      ! *  valero  mars 2006
      xlimf = xspl(npt)
      xf(nfpt) = 0.
      ! omment       yf(nfpt)=0.
      ! look for the number of cells,the limits of the cells, the number of coordinates in each cell
      do i = 1, 15
        npoint(i) = 0
      end do
      ncell = 1
      xlim(ncell) = xf(1)
      do i = 2, nfpt
        if (xf(i)==0.) then
          ncell = ncell + 1
          xlim(ncell) = xlimf
          go to 30
        end if
        if (yf(i)*yf(i-1)<0.) then
          ncell = ncell + 1
          xlim(ncell) = xf(i)
        else
          npoint(ncell) = npoint(ncell) + 1
        end if
      end do
30    continue
      flength = xlim(ncell)
      ncell = ncell - 1
      ! write(16,*) ' ******Read the field of the cavity************'
      write (16, 100) ncell, flength, att, fhc
100   format (' Number of cells: ', i3, ' field length: ', e12.5, 'cm', ' field factor: ', e12.5, ' frequency: ', e12.5, &
        ' Hz')
      ! ******************************************
      ! sv 28/10/2015
      call celint
      ! *****************************************
      do i = 1, ncell
        write (16, 200) i, xlim(i), xlim(i+1), avrg(i)
      end do
200   format (' Cell number ', i3, ' lower limit ', e12.5, ' cm ', ' upper limit ', e12.5, ' cm ', 'average ', e12.5, &
        ' cm')
      return
    end subroutine fieldcav
    ! *******************************************************************
    ! SUBROUTINE celint
    ! average position in the cell
    ! *******************************************************************
    subroutine celint
      implicit real *8(a-h, o-z)
      common /cavnum1/xnh, xpas, fmult, npt
      common /consta/vl, pi, xmat, rpel, qst
      common /spl/xspl(4000), yspl(4000), s(5000), p(5000), q(5000)
      common /cell/yf(10000), xf(10000), xlim(15), flength, fhc, att, npoint(15), ncell
      common /kcell/avrg(15)

      xlpos = 0.
      isce = 20
      xlcum = 0.
      do inc = 1, ncell
        xint1 = 0.
        xint2 = 0.
        xnh = 0.
        xlcel = xlim(inc+1) - xlim(inc)
        xlpos = xlpos + xlcel
        xpas = xlcel/float(isce)
        xnhc = 0
        estop = xpas/10.
        istop = 0
20      continue
        xpat = xnhc*xpas
        if (xpat<(xlcel-estop)) then
          z0 = xnh*xpas
          z1 = (xnh+0.20)*xpas
          z2 = (xnh+0.40)*xpas
          z3 = (xnh+0.60)*xpas
          z4 = (xnh+0.80)*xpas
          z5 = (xnh+1.00)*xpas
          fpos0 = xnh*xpas + xlcum
          fpos1 = (xnh+0.20)*xpas + xlcum
          fpos2 = (xnh+0.40)*xpas + xlcum
          fpos3 = (xnh+0.60)*xpas + xlcum
          fpos4 = (xnh+0.80)*xpas + xlcum
          fpos5 = (xnh+1.0)*xpas + xlcum
          tspl0 = spline(npt, fpos0)
          tspl1 = spline(npt, fpos1)
          tspl2 = spline(npt, fpos2)
          tspl3 = spline(npt, fpos3)
          tspl4 = spline(npt, fpos4)
          tspl5 = spline(npt, fpos5)
          xspl0 = z0*tspl0
          xspl1 = z1*tspl1
          xspl2 = z2*tspl2
          xspl3 = z3*tspl3
          xspl4 = z4*tspl4
          xspl5 = z5*tspl5
          ! integral E(z)*z over the cell
          tspl11 = 19.*xspl0 + 75.*xspl1 + 50.*xspl2 + 50.*xspl3 + 75.*xspl4 + 19.*xspl5
          xi1 = xpas/288.*tspl11
          xint1 = xint1 + xi1
          xspl0 = tspl0
          xspl1 = tspl1
          xspl2 = tspl2
          xspl3 = tspl3
          xspl4 = tspl4
          xspl5 = tspl5
          ! integral E(z) over the cell
          tspl2 = 19.*xspl0 + 75.*xspl1 + 50.*xspl2 + 50.*xspl3 + 75.*xspl4 + 19.*xspl5
          xi2 = xpas/288.*tspl2
          xint2 = xint2 + xi2
          xnh = xnh + 1.
          xnhc = xnhc + 1
          go to 20
        end if
        avrg(inc) = xint1/xint2 + xlcum
        xlcum = xlcum + xlcel
      end do
      return
    end subroutine celint
    ! *******************************************************************
    ! FUNCTION fcav(xc,nrc)
    ! electromagnetic field  at the position xc
    ! *******************************************************************
    function fcav(xc, nrc)
      implicit real *8(a-h, o-z)
      common /cell/yf(10000), xf(10000), xlim(15), flength, fhc, att, npoint(15), ncell
      common /fcv/jsav

      fcav = 0.
      if (nrc==1) then
        j = 1
      else
        j = jsav
      end if
      do k = 1, npoint(nrc)
        tk = xc - xf(j)
        if (tk==0.) then
          fcav = yf(j)
          go to 10
        end if
        if (tk<0.) then
          a = (xc-xf(j-1))/(xf(j)-xf(j-1))
          b = (xf(j)-xc)/(xf(j)-xf(j-1))
          fcav = b*yf(j-1) + a*yf(j)
          go to 10
        end if
        j = j + 1
      end do
10    continue
      jsav = j
      return
    end function fcav
    ! *******************************************************************
    ! FUNCTION ta0(betr,nrc)
    ! Transit time factor t(k) (single cell)
    ! *******************************************************************
    function ta0(betr, nrc)
      implicit real *8(a-h, o-z)
      common /consta/vl, pi, xmat, rpel, qst
      common /cell/yf(10000), xf(10000), xlim(15), flength, fhc, att, npoint(15), ncell
      common /gaus13/h(13), t(13)
      common /gaus17/h1(17), t1(17)
      common /fcv/jsav

      xk = fhc*2.*pi/(betr*vl)
      ar = 0.
      xc1 = xlim(nrc)
      xc2 = xlim(nrc+1)
      do i = 1, 17
        xc = (xc2+xc1)/2. + (xc2-xc1)*h1(i)/2.
        rfonc = fcav(xc, nrc)
        ar = ar + t1(i)*rfonc*cos(xk*xc)
      end do
      ta0 = ar*(xc2-xc1)
      return
    end function ta0
    ! *******************************************************************
    ! FUNCTION tta0(betr)
    ! Transit time factor t(k) (multi-cells)
    ! *******************************************************************
    function tta0(betr)
      implicit real *8(a-h, o-z)
      common /cell/yf(10000), xf(10000), xlim(15), flength, fhc, att, npoint(15), ncell
      common /consta/vl, pi, xmat, rpel, qst
      common /func/a(200), ylg, atte, ncel, nharm
      common /ttfc/tk, t1k, t2k, sk, s1k, s2k, fh
      common /rfield/ifield
      common /gaus13/h(13), t(13)
      dimension xmin(15)
      logical ifield

      if (ifield) then
        tta0 = 0.
        do i = 1, ncell
          tta0 = tta0 + ta0(betr, i)
        end do
      else
        xk = fh/(betr*vl)
        xmin(1) = 0.
        do i = 2, ncel + 2
          xmin(i) = 0.
        end do
        do i = 2, ncel + 1
          xmin(i) = ylg*(i-1)/ncel
        end do
        ipas = 1
        tta0 = 0.
        ar = 0.
101     continue
        if (xmin(ipas+1)==0 .or. ipas>(ncel+2)) return
        do i = 1, 13
          xc1 = xmin(ipas)
          xc2 = xmin(ipas+1)
          xc = (xc2+xc1)/2. + (xc2-xc1)*t(i)/2.
          rfonc = fone(xc)
          ar = ar + h(i)*rfonc*cos(xk*xc)
        end do
        ar = ar*(xc2-xc1)
        tta0 = tta0 + ar
        ar = 0.
        ipas = ipas + 1
        go to 101
      end if
      return
    end function tta0
    ! *******************************************************************
    ! FUNCTION ta1(betr,nrc)
    ! Transit time factor dT(k)/dk (single cell)
    ! *******************************************************************
    function ta1(betr, nrc)
      implicit real *8(a-h, o-z)
      common /cell/yf(10000), xf(10000), xlim(15), flength, fhc, att, npoint(15), ncell
      common /consta/vl, pi, xmat, rpel, qst
      common /gaus13/h(13), t(13)
      common /gaus17/h1(17), t1(17)

      xk = fhc*2.*pi/(betr*vl)
      ar = 0.
      xc1 = xlim(nrc)
      xc2 = xlim(nrc+1)
      do i = 1, 17
        xc = (xc2+xc1)/2. + (xc2-xc1)*h1(i)/2.
        rfonc = fcav(xc, nrc)
        ar = ar - t1(i)*xc*rfonc*sin(xk*xc)
      end do
      ta1 = ar*(xc2-xc1)
      return
    end function ta1
    ! *******************************************************************
    ! FUNCTION tta1(BETR)
    ! Transit time factor dT(k)/dk (multi-cells)
    ! *******************************************************************
    function tta1(betr)
      implicit real *8(a-h, o-z)
      common /cell/yf(10000), xf(10000), xlim(15), flength, fhc, att, npoint(15), ncell
      common /consta/vl, pi, xmat, rpel, qst
      common /func/a(200), ylg, atte, ncel, nharm
      common /ttfc/tk, t1k, t2k, sk, s1k, s2k, fh
      common /rfield/ifield
      common /gaus13/h(13), t(13)
      dimension xmin(15)
      logical ifield

      if (ifield) then
        tta1 = 0.
        do i = 1, ncell
          tta1 = tta1 + ta1(betr, i)
        end do
        return
      else
        xk = fh/(betr*vl)
        xmin(1) = 0.
        do i = 2, ncel + 2
          xmin(i) = 0.
        end do
        do i = 2, ncel + 1
          xmin(i) = ylg*(i-1)/ncel
        end do
        ipas = 1
        tta1 = 0.
        ar = 0.
101     continue
        if (xmin(ipas+1)==0 .or. ipas>(ncel+2)) return
        do i = 1, 13
          xc1 = xmin(ipas)
          xc2 = xmin(ipas+1)
          xc = (xc2+xc1)/2. + (xc2-xc1)*t(i)/2.
          rfonc = fone(xc)
          ar = ar - h(i)*xc*rfonc*sin(xk*xc)
        end do
        ar = ar*(xc2-xc1)
        tta1 = tta1 + ar
        ar = 0.
        ipas = ipas + 1
        go to 101
      end if
    end function tta1
    ! *******************************************************************
    ! FUNCTION ta2(betr,nrc)
    ! Transit time factor d2T(k)/dk2 (single cell)
    ! *******************************************************************
    function ta2(betr, nrc)
      implicit real *8(a-h, o-z)
      common /cell/yf(10000), xf(10000), xlim(15), flength, fhc, att, npoint(15), ncell
      common /consta/vl, pi, xmat, rpel, qst
      common /gaus13/h(13), t(13)
      common /gaus17/h1(17), t1(17)

      xk = fhc*2.*pi/(betr*vl)
      ar = 0.
      xc1 = xlim(nrc)
      xc2 = xlim(nrc+1)
      do i = 1, 17
        xc = (xc2+xc1)/2. + (xc2-xc1)*h1(i)/2.
        rfonc = fcav(xc, nrc)
        ar = ar - t1(i)*xc*xc*rfonc*cos(xk*xc)
      end do
      ta2 = ar*(xc2-xc1)
      return
    end function ta2
    ! *******************************************************************
    ! FUNCTION tta2(BETR)
    ! Transit time factor d2T(k)/dk2 (multi-cells)
    ! *******************************************************************
    function tta2(betr)
      implicit real *8(a-h, o-z)
      common /cell/yf(10000), xf(10000), xlim(15), flength, fhc, att, npoint(15), ncell
      common /consta/vl, pi, xmat, rpel, qst
      common /func/a(200), ylg, atte, ncel, nharm
      common /ttfc/tk, t1k, t2k, sk, s1k, s2k, fh
      common /rfield/ifield
      common /gaus13/h(13), t(13)
      dimension xmin(15)
      logical ifield

      if (ifield) then
        tta2 = 0.
        do i = 1, ncell
          tta2 = tta2 + ta2(betr, i)
        end do
        return
      else
        xk = fh/(betr*vl)
        xmin(1) = 0.
        do i = 2, ncel + 2
          xmin(i) = 0.
        end do
        do i = 2, ncel + 1
          xmin(i) = ylg*(i-1)/ncel
        end do
        ipas = 1
        tta2 = 0.
        ar = 0.
101     continue
        if (xmin(ipas+1)==0 .or. ipas>(ncel+2)) return
        do i = 1, 13
          xc1 = xmin(ipas)
          xc2 = xmin(ipas+1)
          xc = (xc2+xc1)/2. + (xc2-xc1)*t(i)/2.
          rfonc = fone(xc)
          ar = ar - h(i)*xc*xc*rfonc*cos(xk*xc)
        end do
        ar = ar*(xc2-xc1)
        tta2 = tta2 + ar
        ar = 0.
        ipas = ipas + 1
        go to 101
      end if
    end function tta2
    ! *******************************************************************
    ! FUNCTION ta3(betr,nrc)
    ! Transit time factor d3T(k)/dk3 (single cell)
    ! *******************************************************************
    function ta3(betr, nrc)
      implicit real *8(a-h, o-z)
      common /cell/yf(10000), xf(10000), xlim(15), flength, fhc, att, npoint(15), ncell
      common /consta/vl, pi, xmat, rpel, qst
      common /gaus13/h(13), t(13)
      common /gaus17/h1(17), t1(17)

      xk = fhc*2.*pi/(betr*vl)
      ar = 0.
      xc1 = xlim(nrc)
      xc2 = xlim(nrc+1)
      do i = 1, 17
        xc = (xc2+xc1)/2. + (xc2-xc1)*h1(i)/2.
        rfonc = fcav(xc, nrc)
        ar = ar + t1(i)*xc*xc*xc*rfonc*sin(xk*xc)
      end do
      ta3 = ar*(xc2-xc1)
      return
    end function ta3
    ! *******************************************************************
    ! FUNCTION tta3(BETR)
    ! Transit time factor d3T(k)/dk2 (multi-cells)
    ! *******************************************************************
    function tta3(betr)
      implicit real *8(a-h, o-z)
      common /cell/yf(10000), xf(10000), xlim(15), flength, fhc, att, npoint(15), ncell
      common /consta/vl, pi, xmat, rpel, qst
      common /func/a(200), ylg, atte, ncel, nharm
      common /ttfc/tk, t1k, t2k, sk, s1k, s2k, fh
      common /rfield/ifield
      common /gaus13/h(13), t(13)
      dimension xmin(15)
      logical ifield

      if (ifield) then
        tta3 = 0.
        do i = 1, ncell
          tta3 = tta3 + ta3(betr, i)
        end do
        return
      else
        xk = fh/(betr*vl)
        xmin(1) = 0.
        do i = 2, ncel + 2
          xmin(i) = 0.
        end do
        do i = 2, ncel + 1
          xmin(i) = ylg*(i-1)/ncel
        end do
        ipas = 1
        tta3 = 0.
        ar = 0.
101     continue
        if (xmin(ipas+1)==0 .or. ipas>(ncel+2)) return
        do i = 1, 13
          xc1 = xmin(ipas)
          xc2 = xmin(ipas+1)
          xc = (xc2+xc1)/2. + (xc2-xc1)*t(i)/2.
          rfonc = fone(xc)
          ar = ar + h(i)*xc*xc*xc*rfonc*sin(xk*xc)
        end do
        ar = ar*(xc2-xc1)
        tta3 = tta3 + ar
        ar = 0.
        ipas = ipas + 1
        go to 101
      end if
    end function tta3
    ! *******************************************************************
    ! FUNCTION ta4(betr,nrc)
    ! Transit time factor d4T(k)/dk4 (single cell)
    ! *******************************************************************
    function ta4(betr, nrc)
      implicit real *8(a-h, o-z)
      common /cell/yf(10000), xf(10000), xlim(15), flength, fhc, att, npoint(15), ncell
      common /consta/vl, pi, xmat, rpel, qst
      common /gaus13/h(13), t(13)
      common /gaus17/h1(17), t1(17)

      xk = fhc*2.*pi/(betr*vl)
      ar = 0.
      xc1 = xlim(nrc)
      xc2 = xlim(nrc+1)
      do i = 1, 17
        xc = (xc2+xc1)/2. + (xc2-xc1)*h1(i)/2.
        rfonc = fcav(xc, nrc)
        ar = ar + t1(i)*xc**4*rfonc*cos(xk*xc)
      end do
      ta4 = ar*(xc2-xc1)
      return
    end function ta4
    ! *******************************************************************
    ! FUNCTION tta4(BETR)
    ! Transit time factor d4T(k)/dk4 (multi-cells)
    ! *******************************************************************
    function tta4(betr)
      implicit real *8(a-h, o-z)
      common /cell/yf(10000), xf(10000), xlim(15), flength, fhc, att, npoint(15), ncell
      common /consta/vl, pi, xmat, rpel, qst
      common /func/a(200), ylg, atte, ncel, nharm
      common /ttfc/tk, t1k, t2k, sk, s1k, s2k, fh
      common /rfield/ifield
      common /gaus13/h(13), t(13)
      dimension xmin(15)
      logical ifield

      if (ifield) then
        tta4 = 0.
        do i = 1, ncell
          tta4 = tta4 + ta4(betr, i)
        end do
        return
      else
        xk = fh/(betr*vl)
        xmin(1) = 0.
        do i = 2, ncel + 2
          xmin(i) = 0.
        end do
        do i = 2, ncel + 1
          xmin(i) = ylg*(i-1)/ncel
        end do
        ipas = 1
        tta4 = 0.
        ar = 0.
101     continue
        if (xmin(ipas+1)==0 .or. ipas>(ncel+2)) return
        do i = 1, 13
          xc1 = xmin(ipas)
          xc2 = xmin(ipas+1)
          xc = (xc2+xc1)/2. + (xc2-xc1)*t(i)/2.
          rfonc = fone(xc)
          ar = ar + h(i)*xc**4*rfonc*cos(xk*xc)
        end do
        ar = ar*(xc2-xc1)
        tta4 = tta4 + ar
        ar = 0.
        ipas = ipas + 1
        go to 101
      end if
    end function tta4
    ! *******************************************************************
    ! FUNCTION ta5(betr,nrc)
    ! Transit time factor d5T(k)/dk5 (single cell)
    ! *******************************************************************
    function ta5(betr, nrc)
      implicit real *8(a-h, o-z)
      common /cell/yf(10000), xf(10000), xlim(15), flength, fhc, att, npoint(15), ncell
      common /consta/vl, pi, xmat, rpel, qst
      common /gaus13/h(13), t(13)
      common /gaus17/h1(17), t1(17)

      xk = fhc*2.*pi/(betr*vl)
      ar = 0.
      xc1 = xlim(nrc)
      xc2 = xlim(nrc+1)
      do i = 1, 17
        xc = (xc2+xc1)/2. + (xc2-xc1)*h1(i)/2.
        rfonc = fcav(xc, nrc)
        ar = ar - t1(i)*xc**5*rfonc*sin(xk*xc)
      end do
      ta5 = ar*(xc2-xc1)
      return
    end function ta5
    ! *******************************************************************
    ! FUNCTION tta5(BETR)
    ! Transit time factor d5T(k)/dk5 (multi-cells)
    ! *******************************************************************
    function tta5(betr)
      implicit real *8(a-h, o-z)
      common /cell/yf(10000), xf(10000), xlim(15), flength, fhc, att, npoint(15), ncell
      common /consta/vl, pi, xmat, rpel, qst
      common /func/a(200), ylg, atte, ncel, nharm
      common /ttfc/tk, t1k, t2k, sk, s1k, s2k, fh
      common /rfield/ifield
      common /gaus13/h(13), t(13)
      dimension xmin(15)
      logical ifield

      if (ifield) then
        tta5 = 0.
        do i = 1, ncell
          tta5 = tta5 + ta5(betr, i)
        end do
        return
      else
        xk = fh/(betr*vl)
        xmin(1) = 0.
        do i = 2, ncel + 2
          xmin(i) = 0.
        end do
        do i = 2, ncel + 1
          xmin(i) = ylg*(i-1)/ncel
        end do
        ipas = 1
        tta5 = 0.
        ar = 0.
101     continue
        if (xmin(ipas+1)==0 .or. ipas>(ncel+2)) return
        do i = 1, 13
          xc1 = xmin(ipas)
          xc2 = xmin(ipas+1)
          xc = (xc2+xc1)/2. + (xc2-xc1)*t(i)/2.
          rfonc = fone(xc)
          ar = ar - h(i)*xc**5*rfonc*sin(xk*xc)
        end do
        ar = ar*(xc2-xc1)
        tta5 = tta5 + ar
        ar = 0.
        ipas = ipas + 1
        go to 101
      end if
    end function tta5
    ! *******************************************************************
    ! FUNCTION sb0(BETR,nrc)
    ! Transit time factor s(k) (single cell)
    ! *******************************************************************
    function sb0(betr, nrc)
      implicit real *8(a-h, o-z)
      common /cell/yf(10000), xf(10000), xlim(15), flength, fhc, att, npoint(15), ncell
      common /consta/vl, pi, xmat, rpel, qst
      common /gaus13/h(13), t(13)
      common /gaus17/h1(17), t1(17)

      xk = fhc*2.*pi/(betr*vl)
      xc1 = xlim(nrc)
      xc2 = xlim(nrc+1)
      br = 0.
      do i = 1, 17
        xc = (xc2+xc1)/2. + (xc2-xc1)*h1(i)/2.
        rfonc = fcav(xc, nrc)
        br = br + t1(i)*rfonc*sin(xk*xc)
      end do
      sb0 = br*(xc2-xc1)
      return
    end function sb0
    ! *******************************************************************
    ! FUNCTION tsb0(BETR)
    ! Transit time factor s(k) (multi-cells)
    ! *******************************************************************
    function tsb0(betr)
      implicit real *8(a-h, o-z)
      common /cell/yf(10000), xf(10000), xlim(15), flength, fhc, att, npoint(15), ncell
      common /consta/vl, pi, xmat, rpel, qst
      common /func/a(200), ylg, atte, ncel, nharm
      common /ttfc/tk, t1k, t2k, sk, s1k, s2k, fh
      common /rfield/ifield
      common /gaus13/h(13), t(13)
      dimension xmin(15)
      logical ifield

      if (ifield) then
        tsb0 = 0.
        do i = 1, ncell
          tsb0 = tsb0 + sb0(betr, i)
        end do
        return
      else
        xk = fh/(betr*vl)
        xmin(1) = 0.
        do i = 2, ncel + 2
          xmin(i) = 0.
        end do
        do i = 2, ncel + 1
          xmin(i) = ylg*(i-1)/ncel
        end do
        ipas = 1
        tsb0 = 0.
        br = 0.
101     continue
        if (xmin(ipas+1)==0 .or. ipas>(ncel+2)) return
        do i = 1, 13
          xc1 = xmin(ipas)
          xc2 = xmin(ipas+1)
          xc = (xc2+xc1)/2. + (xc2-xc1)*t(i)/2.
          rfonc = fone(xc)
          br = br + h(i)*rfonc*sin(xk*xc)
        end do
        br = br*(xc2-xc1)
        tsb0 = tsb0 + br
        br = 0.
        ipas = ipas + 1
        go to 101
      end if
    end function tsb0
    ! *******************************************************************
    ! FUNCTION sb1(BETR,nrc)
    ! Transit time factor dS(k)/dk (single cell)
    ! *******************************************************************
    function sb1(betr, nrc)
      implicit real *8(a-h, o-z)
      common /cell/yf(10000), xf(10000), xlim(15), flength, fhc, att, npoint(15), ncell
      common /consta/vl, pi, xmat, rpel, qst
      common /gaus13/h(13), t(13)
      common /gaus17/h1(17), t1(17)

      xk = fhc*2.*pi/(betr*vl)
      xc1 = xlim(nrc)
      xc2 = xlim(nrc+1)
      br = 0.
      do i = 1, 17
        xc = (xc2+xc1)/2. + (xc2-xc1)*h1(i)/2.
        rfonc = fcav(xc, nrc)
        br = br + t1(i)*xc*rfonc*cos(xk*xc)
      end do
      sb1 = br*(xc2-xc1)
      return
    end function sb1
    ! *******************************************************************
    ! FUNCTION tsb1(BETR)
    ! Transit time factor ds(k)/dk (multi-cells)
    ! *******************************************************************
    function tsb1(betr)
      implicit real *8(a-h, o-z)
      common /cell/yf(10000), xf(10000), xlim(15), flength, fhc, att, npoint(15), ncell
      common /consta/vl, pi, xmat, rpel, qst
      common /func/a(200), ylg, atte, ncel, nharm
      common /ttfc/tk, t1k, t2k, sk, s1k, s2k, fh
      common /rfield/ifield
      common /gaus13/h(13), t(13)
      dimension xmin(15)
      logical ifield

      if (ifield) then
        tsb1 = 0.
        do i = 1, ncell
          tsb1 = tsb1 + sb1(betr, i)
        end do
        return
      else
        xk = fh/(betr*vl)
        xmin(1) = 0.
        do i = 2, ncel + 2
          xmin(i) = 0.
        end do
        do i = 2, ncel + 1
          xmin(i) = ylg*(i-1)/ncel
        end do
        ipas = 1
        tsb1 = 0.
        br = 0.
101     continue
        if (xmin(ipas+1)==0 .or. ipas>(ncel+2)) return
        do i = 1, 13
          xc1 = xmin(ipas)
          xc2 = xmin(ipas+1)
          xc = (xc2+xc1)/2. + (xc2-xc1)*t(i)/2.
          rfonc = fone(xc)
          br = br + h(i)*xc*rfonc*cos(xk*xc)
        end do
        br = br*(xc2-xc1)
        tsb1 = tsb1 + br
        br = 0.
        ipas = ipas + 1
        go to 101
      end if
    end function tsb1
    ! *******************************************************************
    ! FUNCTION sb2(BETR,nrc)
    ! Transit time factor d2S(k)/dk2 (single cell)
    ! *******************************************************************
    function sb2(betr, nrc)
      implicit real *8(a-h, o-z)
      common /cell/yf(10000), xf(10000), xlim(15), flength, fhc, att, npoint(15), ncell
      common /consta/vl, pi, xmat, rpel, qst
      common /gaus13/h(13), t(13)
      common /gaus17/h1(17), t1(17)

      xk = fhc*2.*pi/(betr*vl)
      xc1 = xlim(nrc)
      xc2 = xlim(nrc+1)
      br = 0.
      do i = 1, 17
        xc = (xc2+xc1)/2. + (xc2-xc1)*h1(i)/2.
        rfonc = fcav(xc, nrc)
        br = br - t1(i)*xc*xc*rfonc*sin(xk*xc)
      end do
      sb2 = br*(xc2-xc1)
      return
    end function sb2
    ! *******************************************************************
    ! FUNCTION tsb2(BETR)
    ! Transit time factor d2S(k)/dk2 (multi-cells)
    ! *******************************************************************
    function tsb2(betr)
      implicit real *8(a-h, o-z)
      common /cell/yf(10000), xf(10000), xlim(15), flength, fhc, att, npoint(15), ncell
      common /consta/vl, pi, xmat, rpel, qst
      common /func/a(200), ylg, atte, ncel, nharm
      common /ttfc/tk, t1k, t2k, sk, s1k, s2k, fh
      common /rfield/ifield
      common /gaus13/h(13), t(13)
      dimension xmin(15)
      logical ifield

      if (ifield) then
        tsb2 = 0.
        do i = 1, ncell
          tsb2 = tsb2 + sb2(betr, i)
        end do
        return
      else
        xk = fh/(betr*vl)
        xmin(1) = 0.
        do i = 2, ncel + 2
          xmin(i) = 0.
        end do
        do i = 2, ncel + 1
          xmin(i) = ylg*(i-1)/ncel
        end do
        ipas = 1
        tsb2 = 0.
        br = 0.
101     continue
        if (xmin(ipas+1)==0 .or. ipas>(ncel+2)) return
        do i = 1, 13
          xc1 = xmin(ipas)
          xc2 = xmin(ipas+1)
          xc = (xc2+xc1)/2. + (xc2-xc1)*t(i)/2.
          rfonc = fone(xc)
          br = br - h(i)*xc*xc*rfonc*sin(xk*xc)
        end do
        br = br*(xc2-xc1)
        tsb2 = tsb2 + br
        br = 0.
        ipas = ipas + 1
        go to 101
      end if
    end function tsb2
    ! *******************************************************************
    ! FUNCTION sb3(BETR,nrc)
    ! Transit time factor d3S(k)/dk3 (single cell)
    ! *******************************************************************
    function sb3(betr, nrc)
      implicit real *8(a-h, o-z)
      common /cell/yf(10000), xf(10000), xlim(15), flength, fhc, att, npoint(15), ncell
      common /consta/vl, pi, xmat, rpel, qst
      common /gaus13/h(13), t(13)
      common /gaus17/h1(17), t1(17)

      xk = fhc*2.*pi/(betr*vl)
      xc1 = xlim(nrc)
      xc2 = xlim(nrc+1)
      br = 0.
      do i = 1, 17
        xc = (xc2+xc1)/2. + (xc2-xc1)*h1(i)/2.
        rfonc = fcav(xc, nrc)
        br = br - t1(i)*xc*xc*xc*rfonc*cos(xk*xc)
      end do
      sb3 = br*(xc2-xc1)
      return
    end function sb3
    ! *******************************************************************
    ! FUNCTION tsb3(BETR)
    ! Transit time factor d3S(k)/dk3 (multi-cells)
    ! *******************************************************************
    function tsb3(betr)
      implicit real *8(a-h, o-z)
      common /cell/yf(10000), xf(10000), xlim(15), flength, fhc, att, npoint(15), ncell
      common /consta/vl, pi, xmat, rpel, qst
      common /func/a(200), ylg, atte, ncel, nharm
      common /ttfc/tk, t1k, t2k, sk, s1k, s2k, fh
      common /rfield/ifield
      common /gaus13/h(13), t(13)
      dimension xmin(15)
      logical ifield

      if (ifield) then
        tsb3 = 0.
        do i = 1, ncell
          tsb3 = tsb3 + sb3(betr, i)
        end do
        return
      else
        xk = fh/(betr*vl)
        xmin(1) = 0.
        do i = 2, ncel + 2
          xmin(i) = 0.
        end do
        do i = 2, ncel + 1
          xmin(i) = ylg*(i-1)/ncel
        end do
        ipas = 1
        tsb3 = 0.
        br = 0.
101     continue
        if (xmin(ipas+1)==0 .or. ipas>(ncel+2)) return
        do i = 1, 13
          xc1 = xmin(ipas)
          xc2 = xmin(ipas+1)
          xc = (xc2+xc1)/2. + (xc2-xc1)*t(i)/2.
          rfonc = fone(xc)
          br = br - h(i)*xc*xc*xc*rfonc*cos(xk*xc)
        end do
        br = br*(xc2-xc1)
        tsb3 = tsb3 + br
        br = 0.
        ipas = ipas + 1
        go to 101
      end if
    end function tsb3
    ! *******************************************************************
    ! FUNCTION sb4(BETR,nrc)
    ! Transit time factor d4S(k)/dk5 (single cell)
    ! *******************************************************************
    function sb4(betr, nrc)
      implicit real *8(a-h, o-z)
      common /cell/yf(10000), xf(10000), xlim(15), flength, fhc, att, npoint(15), ncell
      common /consta/vl, pi, xmat, rpel, qst
      common /gaus13/h(13), t(13)
      common /gaus17/h1(17), t1(17)

      xk = fhc*2.*pi/(betr*vl)
      xc1 = xlim(nrc)
      xc2 = xlim(nrc+1)
      br = 0.
      do i = 1, 17
        xc = (xc2+xc1)/2. + (xc2-xc1)*h1(i)/2.
        rfonc = fcav(xc, nrc)
        br = br + t1(i)*xc**4*rfonc*sin(xk*xc)
      end do
      sb4 = br*(xc2-xc1)
      return
    end function sb4
    ! *******************************************************************
    ! FUNCTION tsb4(BETR)
    ! Transit time factor d4S(k)/dk5 (multi cells)
    ! *******************************************************************
    function tsb4(betr)
      implicit real *8(a-h, o-z)
      common /cell/yf(10000), xf(10000), xlim(15), flength, fhc, att, npoint(15), ncell
      common /consta/vl, pi, xmat, rpel, qst
      common /func/a(200), ylg, atte, ncel, nharm
      common /ttfc/tk, t1k, t2k, sk, s1k, s2k, fh
      common /rfield/ifield
      common /gaus13/h(13), t(13)
      dimension xmin(15)
      logical ifield

      if (ifield) then
        tsb4 = 0.
        do i = 1, ncell
          tsb4 = tsb4 + sb4(betr, i)
        end do
        return
      else
        xk = fh/(betr*vl)
        xmin(1) = 0.
        do i = 2, ncel + 2
          xmin(i) = 0.
        end do
        do i = 2, ncel + 1
          xmin(i) = ylg*(i-1)/ncel
        end do
        ipas = 1
        tsb4 = 0.
        br = 0.
101     continue
        if (xmin(ipas+1)==0 .or. ipas>(ncel+2)) return
        do i = 1, 13
          xc1 = xmin(ipas)
          xc2 = xmin(ipas+1)
          xc = (xc2+xc1)/2. + (xc2-xc1)*t(i)/2.
          rfonc = fone(xc)
          br = br + h(i)*xc**4*rfonc*sin(xk*xc)
        end do
        br = br*(xc2-xc1)
        tsb4 = tsb4 + br
        br = 0.
        ipas = ipas + 1
        go to 101
      end if
    end function tsb4
    ! *******************************************************************
    ! FUNCTION sb5(BETR,nrc)
    ! Transit time factor d5S(k)/dk5 (single cell)
    ! *******************************************************************
    function sb5(betr, nrc)
      implicit real *8(a-h, o-z)
      common /cell/yf(10000), xf(10000), xlim(15), flength, fhc, att, npoint(15), ncell
      common /consta/vl, pi, xmat, rpel, qst
      common /gaus13/h(13), t(13)
      common /gaus17/h1(17), t1(17)

      xk = fhc*2.*pi/(betr*vl)
      xc1 = xlim(nrc)
      xc2 = xlim(nrc+1)
      br = 0.
      do i = 1, 17
        xc = (xc2+xc1)/2. + (xc2-xc1)*h1(i)/2.
        rfonc = fcav(xc, nrc)
        br = br + t1(i)*xc**5*rfonc*cos(xk*xc)
      end do
      sb5 = br*(xc2-xc1)
      return
    end function sb5
    ! *******************************************************************
    ! FUNCTION tsb5(BETR)
    ! Transit time factor d5S(k)/dk5
    ! *******************************************************************
    function tsb5(betr)
      implicit real *8(a-h, o-z)
      common /cell/yf(10000), xf(10000), xlim(15), flength, fhc, att, npoint(15), ncell
      common /consta/vl, pi, xmat, rpel, qst
      common /func/a(200), ylg, atte, ncel, nharm
      common /ttfc/tk, t1k, t2k, sk, s1k, s2k, fh
      common /rfield/ifield
      common /gaus13/h(13), t(13)
      dimension xmin(15)
      logical ifield

      if (ifield) then
        tsb5 = 0.
        do i = 1, ncell
          tsb5 = tsb5 + sb5(betr, i)
        end do
        return
      else
        xk = fh/(betr*vl)
        xmin(1) = 0.
        do i = 2, ncel + 2
          xmin(i) = 0.
        end do
        do i = 2, ncel + 1
          xmin(i) = ylg*(i-1)/ncel
        end do
        ipas = 1
        tsb5 = 0.
        br = 0.
101     continue
        if (xmin(ipas+1)==0 .or. ipas>(ncel+2)) return
        do i = 1, 13
          xc1 = xmin(ipas)
          xc2 = xmin(ipas+1)
          xc = (xc2+xc1)/2. + (xc2-xc1)*t(i)/2.
          rfonc = fone(xc)
          br = br + h(i)*xc**5*rfonc*cos(xk*xc)
        end do
        br = br*(xc2-xc1)
        tsb5 = tsb5 + br
        br = 0.
        ipas = ipas + 1
        go to 101
      end if
    end function tsb5
    ! *******************************************************************
    ! FUNCTION fone(Z)
    ! Electromagnetic field at the longitudinal point (z,0)
    ! The field harmonics are  stored in  A(200)
    ! *******************************************************************
    function fone(z)
      implicit real *8(a-h, o-z)
      common /consta/vl, pi, xmat, rpel, qst
      common /func/a(200), ylg, atte, ncel, nharm
      common /ttfc/tk, t1k, t2k, sk, s1k, s2k, fh

      fone = 0.
      do j = 1, nharm
        xl = pi*(j-1)/ylg
        fone = fone + a(j)*cos(xl*z)
      end do
      return
    end function fone
    ! *******************************************************************
    ! SUBROUTINE rharm
    ! the field is in the form of a Fourier series expansion
    ! *******************************************************************
    subroutine rharm
      implicit real *8(a-h, o-z)
      common /func/a(200), ylg, atte, ncel, nharm
      common /ttfc/tk, t1k, t2k, sk, s1k, s2k, fh
      common /tapes/in, ifile, meta
      common /consta/vl, pi, xmat, rpel, qst
      common /rfield/ifield
      common /mode/eflvl, rflvl
      logical ifield

      ifield = .false.
      ! ylg: length of the field (cm)
      ! fh: frequency (hertz)
      ! atte: field factor
      ! ncel: number of cells in the cavity
      read (in, *) ylg, fh, atte, ncel
      read (in, *) nharm
      read (in, *)(a(i), i=1, nharm)
      write (16, 100) ncel, ylg, fh, atte
100   format (' number of cells in the cavity: ', i3, /, ' field length: ', e12.5, 'cm', /, ' freq. ', e12.5, ' Hertz', &
        ' field factor ', e12.5)
      write (16, *) ' number of harmonics: ', nharm
      write (16, 200)(a(i), i=1, nharm)
200   format (3(2x,e12.5))
      do i = 1, nharm
        a(i) = a(i)*atte
      end do
      fh = fh*2.*pi
      ! **********************************************
      ! sv 24/10/2015
      xp = ylg/100.
      open (18, file='chemtr.txt', status='unknown')
      zx = 0.
      yh = 0.
98    continue
      do inh = 1, nharm
        ! c        xl=pi*float(inh-1)/ylg
        ! c        yh=yh+a(inh)*cos(xl*zx)
        ff = fone(zx)
      end do
      write (18, 99) zx/100., ff
99    format (3(2x,e12.5))
      zx = zx + xp
      if (zx<ylg) go to 98
      close (18)
      ! **********************************************
      return
    end subroutine rharm
    ! *******************************************************************
    ! SUBROUTINE profil
    ! Store header and envelopes in a binary file for
    ! graphics post-processor
    ! *******************************************************************
    subroutine profil
      implicit real *8(a-h, o-z)
      common /dplt/zdeb, zfin, ywmax, ypmax, rmsn
      common /tapes/in, ifile, meta

      call plprf1
      call plprf2
      return
    end subroutine profil
    ! *******************************************************************
    ! SUBROUTINE plprf1
    ! IPRF  : POINTEUR
    ! RMSN  :envelope size in multiples of RMS size
    ! SPRFX :half horizontal extent (cm)
    ! SPRFY :half vertical extent (cm)
    ! SPRFW :half energy extent (MeV)
    ! SPRFP :half phase extent    (deg)
    ! SPRFL :position along Z(m)
    ! *******************************************************************
    subroutine plprf1
      implicit real *8(a-h, o-z)
      dimension xx(3000), yy(3000)
      ! RMSN  :envelope size in multiples of RMS size
      ! ZDEB : Starting position of the plot
      ! ZFIN : End of the plot
      character *80 car, text
      common /dplt/zdeb, zfin, ywmax, ypmax, rmsn
      common /pltprf/sprfy(3000), sprfz(3000), sprfl(3000), sprfw(3000), sprfp(3000), sprng(3000), iprf
      common /tapes/in, ifile, meta
      common /prof/car

      read (in, 69) car(1:80)
69    format (a80)
      read (in, *) rmsn
      read (in, *) zdeb, zfin
      read (in, *) xxmax, xymax, ywmax, ypmax
      iprf = iprf - 1
      ideb = 1
      ifin = iprf
      if (zfin>sprfl(iprf)) zfin = sprfl(iprf)
      write (16, *) ' ******* PROFIL ***************** '
      write (16, *) ' IPRF ZFIN ', iprf, zfin
      do i = 2, iprf
        if ((zdeb>sprfl(i-1)) .and. (zdeb<=sprfl(i))) ideb = i
        if ((zfin>=sprfl(i-1)) .and. (zfin<sprfl(i))) ifin = i - 1
      end do
      if (xxmax<=0.) then
        xxmax = 0.
        do i = ideb, ifin
          if (0.5*sprfy(i)*rmsn>xxmax) xxmax = 0.5*sprfy(i)*rmsn
        end do
      end if
      if (xymax<=0.) then
        xymax = 0.
        do i = ideb, ifin
          if (0.5*sprfz(i)*rmsn>xymax) xymax = 0.5*sprfz(i)*rmsn
        end do
      end if
      ! Store header and envelopes in binary file for
      ! graphics post-processor

      ! igrtyp is type of graph (igrtyp=3 for x,y envelope plots)
      igrtyp = 3
      text = 'X and Y envelopes   '
      text(21:80) = car(1:60)
      write (66, *) igrtyp
      write (66, *) text
      xx(1) = zdeb
      xx(2) = zfin
      yy(1) = -xymax
      yy(2) = xxmax
      write (16, *) ' XMAX YMAX ', xxmax, xymax
      write (66, *) xx(1), xx(2), yy(1), yy(2)
      ! GRADX=XXMAX/3.
      ! YFAXE=XXMAX
      icnt = 0
      do i = ideb, ifin
        icnt = icnt + 1
        xx(icnt) = sprfl(i)
        yy(icnt) = 0.5*sprfy(i)*rmsn
      end do
      ! write envelope coordinates to graphics file
      write (66, *) icnt
      do i = 1, icnt
        write (66, *) xx(i), yy(i)
      end do
      icnt = 0
      do i = ideb, ifin
        icnt = icnt + 1
        xx(icnt) = sprfl(i)
        yy(icnt) = -0.5*sprfz(i)*rmsn
      end do
      ! write envelope coordinates to graphics file
      write (66, *) icnt
      do i = 1, icnt
        write (66, *) xx(i), yy(i)
      end do
      return
    end subroutine plprf1
    ! *******************************************************************
    ! SUBROUTINE plprf2
    ! Store header and envelopes in binary file for
    ! graphics post-processor
    ! *******************************************************************
    subroutine plprf2
      implicit real *8(a-h, o-z)
      dimension xx(3000), yy(3000)
      character *80 car, text
      common /prof/car
      common /dplt/zdeb, zfin, ywmax, ypmax, rmsn
      common /pltprf/sprfy(3000), sprfz(3000), sprfl(3000), sprfw(3000), sprfp(3000), sprng(3000), iprf

      ideb = 1
      ifin = iprf
      do i = 2, iprf
        if ((zdeb>sprfl(i-1)) .and. (zdeb<=sprfl(i))) ideb = i
        if ((zfin>=sprfl(i-1)) .and. (zfin<sprfl(i))) ifin = i - 1
      end do
      xxmax = ywmax/1000.
      xymax = ypmax
      if (xxmax<=0.) then
        xxmax = 0.
        do i = ideb, ifin
          if (0.5*sprfw(i)*rmsn>xxmax) xxmax = 0.5*sprfw(i)*rmsn
        end do
      end if
      if (xymax<=0.) then
        xymax = 0.
        do i = ideb, ifin
          if (0.5*sprfp(i)*rmsn>xymax) xymax = 0.5*sprfp(i)*rmsn
        end do
      end if
      ! Store header and envelopes in binary file for
      ! graphics post-processor

      ! igrtyp is type of graph (igrtyp=4 for dW/W envelope plots)
      igrtyp = 4
      text = 'dW/W envelope       '
      text(21:80) = car(1:60)
      write (66, *) igrtyp
      write (66, *) text
      xx(1) = zdeb
      xx(2) = zfin
      yy(1) = 0.
      yy(2) = xxmax*1000.
      write (66, *) xx(1), xx(2), yy(1), yy(2)
      icnt = 0
      do i = ideb, ifin
        icnt = icnt + 1
        xx(icnt) = sprfl(i)
        yy(icnt) = 0.5*sprfw(i)*1000.*rmsn
      end do
      ! write envelope coordinates to graphics file
      write (66, *) icnt
      do i = 1, icnt
        write (66, *) xx(i), yy(i)
      end do
      ! Store header and envelopes in binary file for
      ! graphics post-processor

      ! igrtyp is type of graph (igrtyp=5 for dPHI envelope plots)
      igrtyp = 5
      text = 'dPHI envelope       '
      text(21:80) = car(1:60)
      write (66, *) igrtyp
      write (66, *) text
      xx(1) = zdeb
      xx(2) = zfin
      ! 14/08/2009       yy(1)=-xymax
      yy(1) = 0.
      yy(2) = xymax
      write (16, *) ' dW/WMAX dPhiMAX ', xxmax, xymax
      write (66, *) xx(1), xx(2), yy(1), yy(2)
      icnt = 0
      do i = ideb, ifin
        icnt = icnt + 1
        xx(icnt) = sprfl(i)
        yy(icnt) = 0.5*sprfp(i)*rmsn
      end do
      ! write envelope coordinates to graphics file
      write (66, *) icnt
      do i = 1, icnt
        write (66, *) xx(i), yy(i)
      end do
      iprf = iprf + 1
      return
    end subroutine plprf2
    ! *******************************************************************
    ! FUNCTION slope(N,XV)
    ! first derivative of the spline function
    ! *******************************************************************
    function slope(n, xv)
      implicit real *8(a-h, o-z)
      common /spl/x(4000), y(4000), s(5000), p(5000), q(5000)

      do i = 2, n
        xtvi = xv - x(i)
        if (xtvi>0.) go to 4
        if (xtvi<0.) go to 2
        if (xtvi==0.00) go to 3
4       continue
      end do
3     i = i - 1
      avx = x(i+1) - x(i)
      slope = s(i+1)*avx/3. + s(i)*avx/6. + (y(i+1)-y(i))/avx
      return
2     i = i - 1
      dgx = xv - x(i)
      ddx = x(i+1) - xv
      avx = x(i+1) - x(i)
      slope = -(s(i)*ddx*ddx)/(2.*avx) + (s(i+1)*dgx*dgx)/(2.*avx) + ((y(i+1)-y(i))/avx) - (avx*(s(i+1)-s(i))/6.)
      return
    end function slope
    ! *******************************************************************
    ! FUNCTION spline (N,XV)
    ! SPLINE FUNCTION
    ! *******************************************************************
    function spline(n, xv)
      implicit real *8(a-h, o-z)
      common /spl/x(4000), y(4000), s(5000), p(5000), q(5000)

      spline = y(1)
      xtv1 = xv - x(1)
      if (xtv1<0.) then
        spline = y(1) + ((y(2)-y(1))/(x(2)-x(1))-s(2)*(x(2)-x(1))/6.)*(xv-x(1))
        return
      end if
      if (xtv1==0.00) then
        spline = y(1)
        return
      end if
      if (xtv1>0.) then
        xtvn = xv - x(n)
        if (xtvn==0.00) then
          spline = y(n)
          return
        end if
        if (xtvn>0.) then
          spline = y(n) + ((y(n)-y(n-1))/(x(n)-x(n-1))+s(n-1)*(x(n)-x(n-1))/6.)*(xv-x(n))
          return
        end if
        if (xtvn<0.) then
          do i = 2, n
            xtvi = xv - x(i)
            if (xtvi>0.) go to 11
            if (xtvi<0.) go to 2
            if (xtvi==0.) go to 3
11          continue
          end do
3         spline = y(i)
          return
2         i = i - 1
          dgx = xv - x(i)
          ddx = x(i+1) - xv
          avx = x(i+1) - x(i)
          spline = s(i)*ddx**3/(6.*avx) + s(i+1)*dgx**3/(6.*avx) + (y(i+1)/avx-s(i+1)*avx/6.)*dgx + &
            (y(i)/avx-s(i)*avx/6.)*ddx
          return
        end if
      end if
    end function spline
    ! *******************************************************************
    ! SUBROUTINE DERIV2(N)
    ! second derivative of spline functions at position (x,y)
    ! *******************************************************************
    subroutine deriv2(n)
      implicit real *8(a-h, o-z)
      common /spl/x(4000), y(4000), s(5000), p(5000), q(5000)

      avxn = x(n) - x(n-1)
      avvxn = x(n-1) - x(n-2)
      avyn = y(n) - y(n-1)
      avvyn = y(n-1) - y(n-2)
      f = avxn - (avvxn**2)/avxn
      p(n-1) = 1.
      q(n-1) = 0.
      if (f/=0.) then
        p(n-1) = (-2.*avxn-3.*avvxn-avvxn**2/avxn)/f
        q(n-1) = 6.*(avyn/avxn-avvyn/avvxn)/f
      end if
      nm1 = n - 1
      do j = 2, nm1
        i = n - j
        avx = x(i+1) - x(i)
        avvx = x(i+2) - x(i+1)
        avy = y(i+1) - y(i)
        avvy = y(i+2) - y(i+1)
        d = 2.*(avx+avvx) + avvx*p(i+1)
        p(i) = -avx/d
        q(i) = (6.*(avvy/avvx-avy/avx)-avvx*q(i+1))/d
      end do
      avx1 = x(2) - x(1)
      avvx1 = x(3) - x(2)
      g1 = (avvx1/avx1) + 1. - p(2) - (q(2)/q(1))
      g2 = (avvx1/(avx1*p(1))) - (avvx1/avx1) - 1. + p(2)
      s(1) = (q(1)*g1)/(p(1)*g2)
      do i = 1, nm1
        s(i+1) = p(i)*s(i) + q(i)
      end do
      return
    end subroutine deriv2
    ! *******************************************************************
    ! SUBROUTINE DERIF2(N)
    ! second derivative of spline functions at position (x,y)
    ! *******************************************************************
    subroutine derif2(n)
      implicit real *8(a-h, o-z)
      common /spff/x(400), y(400), s(500), p(500), q(500)

      avxn = x(n) - x(n-1)
      avvxn = x(n-1) - x(n-2)
      avyn = y(n) - y(n-1)
      avvyn = y(n-1) - y(n-2)
      f = avxn - (avvxn**2)/avxn
      p(n-1) = 1.
      q(n-1) = 0.
      if (f/=0.) then
        p(n-1) = (-2.*avxn-3.*avvxn-avvxn**2/avxn)/f
        q(n-1) = 6.*(avyn/avxn-avvyn/avvxn)/f
      end if
      nm1 = n - 1
      do j = 2, nm1
        i = n - j
        avx = x(i+1) - x(i)
        avvx = x(i+2) - x(i+1)
        avy = y(i+1) - y(i)
        avvy = y(i+2) - y(i+1)
        d = 2.*(avx+avvx) + avvx*p(i+1)
        p(i) = -avx/d
        q(i) = (6.*(avvy/avvx-avy/avx)-avvx*q(i+1))/d
      end do
      avx1 = x(2) - x(1)
      avvx1 = x(3) - x(2)
      g1 = (avvx1/avx1) + 1. - p(2) - (q(2)/q(1))
      g2 = (avvx1/(avx1*p(1))) - (avvx1/avx1) - 1. + p(2)
      s(1) = (q(1)*g1)/(p(1)*g2)
      do i = 1, nm1
        s(i+1) = p(i)*s(i) + q(i)
      end do
      return
    end subroutine derif2
    ! *******************************************************************
    ! FUNCTION splinf (N,XV)
    ! SPLINE FUNCTION
    ! *******************************************************************
    function splinf(n, xv)
      implicit real *8(a-h, o-z)
      common /spff/x(400), y(400), s(500), p(500), q(500)

      splinf = y(1)
      xtv1 = xv - x(1)
      if (xtv1<0.) then
        splinf = y(1) + ((y(2)-y(1))/(x(2)-x(1))-s(2)*(x(2)-x(1))/6.)*(xv-x(1))
        return
      end if
      if (xtv1==0.00) then
        splinf = y(1)
        return
      end if
      if (xtv1>0.) then
        xtvn = xv - x(n)
        if (xtvn==0.00) then
          splinf = y(n)
          return
        end if
        if (xtvn>0.) then
          splinf = y(n) + ((y(n)-y(n-1))/(x(n)-x(n-1))+s(n-1)*(x(n)-x(n-1))/6.)*(xv-x(n))
          return
        end if
        if (xtvn<0.) then
          do i = 2, n
            xtvi = xv - x(i)
            if (xtvi>0.) go to 11
            if (xtvi<0.) go to 2
            if (xtvi==0.) go to 3
11          continue
          end do
3         splinf = y(i)
          return
2         i = i - 1
          dgx = xv - x(i)
          ddx = x(i+1) - xv
          avx = x(i+1) - x(i)
          splinf = s(i)*ddx**3/(6.*avx) + s(i+1)*dgx**3/(6.*avx) + (y(i+1)/avx-s(i+1)*avx/6.)*dgx + &
            (y(i)/avx-s(i)*avx/6.)*ddx
          return
        end if
      end if
    end function splinf
    ! *******************************************************************
    ! FUNCTION slopf(N,XV)
    ! first derivative of the spline function
    ! *******************************************************************
    function slopf(n, xv)
      implicit real *8(a-h, o-z)
      common /spff/x(400), y(400), s(500), p(500), q(500)

      do i = 2, n
        xtvi = xv - x(i)
        if (xtvi>0.) go to 4
        if (xtvi<0.) go to 2
        if (xtvi==0.00) go to 3
4       continue
      end do
3     i = i - 1
      avx = x(i+1) - x(i)
      slopf = s(i+1)*avx/3. + s(i)*avx/6. + (y(i+1)-y(i))/avx
      return
2     i = i - 1
      dgx = xv - x(i)
      ddx = x(i+1) - xv
      avx = x(i+1) - x(i)
      slopf = -(s(i)*ddx*ddx)/(2.*avx) + (s(i+1)*dgx*dgx)/(2.*avx) + ((y(i+1)-y(i))/avx) - (avx*(s(i+1)-s(i))/6.)
      return
    end function slopf
    ! *******************************************************************
    ! SUBROUTINE area(init)
    ! selection of the regions in the space x/a, y/b and z/c. The values
    ! a,b and c are the RMS of the bunch in the space x, y, and z
    ! The particles lying in any one region are affected with the same
    ! color.
    ! *******************************************************************
    subroutine area(init)
      implicit real *8(a-h, o-z)
      parameter(iptsz=100002, maxcell=3000, maxcell1=3000)
      common /faisc/f(10, iptsz), imax, ngood
      common /consta/vl, pi, xmat, rpel, qst
      common /ttfc/tk, t1k, t2k, sk, s1k, s2k, fh
      common /part/xc(iptsz), yc(iptsz), zc(iptsz)
      common /tapes/in, ifile, meta
      common /zones/frms(6), nzone
      dimension inzonn(6)

      if (init==1) then
        ! set to -1. the last column of the table f(10,iptsz)
        do i = 1, ngood
          f(10, i) = -1.
        end do
        ! read: ityp and nzone; the number of regions
        ! ityp=0, the zones are defined in the 3-d space (x/a,y/b,z/c)
        ! ityp=1, the zones are defined in the plane (x/a,y/b)
        read (in, *) ityp, nzone
        write (16, *) 'Number of zones selected:', nzone
        if (nzone>5) then
          write (16, *) 'Number of zones is greater than 5 ', nzone
          stop
        end if
        ! The regions are selected in the space x/xrms,y/yrms and z/zrms
        ! limits of the zones ; read the upper limits of the regions
        frms(1) = 0.
        if (nzone/=0) then
          read (in, *)(frms(i), i=2, nzone)
          frms(nzone+1) = 100.
          do i = 1, nzone
            write (16, *) 'Zone: ', i, ' lower limit: ', frms(i), ' upper limit:', frms(i+1)
          end do
        else
          read (in, *) frms(2)
        end if
      end if
      if (nzone>=2) then
        trmoy = 0.
        do i = 1, ngood
          trmoy = trmoy + f(6, i)
        end do
        trmoy = trmoy/float(ngood)
        xbar = 0.
        ybar = 0.
        zbar = 0.
        imaxx = 0
        ! Divide by 100. to convert from centimeters to meters
        do np = 1, ngood
          gnp = f(7, np)/xmat
          vnp = vl*sqrt(1.-1./(gnp*gnp))
          zc(np) = (trmoy-f(6,np))*vnp
          ! convert from mrad to rad
          f3 = f(3, np)*1.e-03
          f5 = f(5, np)*1.e-03
          ! convert from cm   to m
          xc(np) = (f(2,np)+zc(np)*f3)/100.
          yc(np) = (f(4,np)+zc(np)*f5)/100.
          zc(np) = zc(np)/100.
          ! evaluate xbar , ybar , zbar
          xbar = xbar + xc(np)
          ybar = ybar + yc(np)
          zbar = zbar + zc(np)
        end do
        eng = float(ngood)
        xbar = xbar/eng
        ybar = ybar/eng
        zbar = zbar/eng
        do np = 1, ngood
          xc(np) = xc(np) - xbar
          yc(np) = yc(np) - ybar
          zc(np) = zc(np) - zbar
        end do
        ! evaluate the rms sizes
        xsqsum = 0.
        ysqsum = 0.
        zsqsum = 0.
        do j = 1, ngood
          xcj = xc(j)
          ycj = yc(j)
          zcj = zc(j)
          xsqsum = xsqsum + xcj*xcj
          ysqsum = ysqsum + ycj*ycj
          zsqsum = zsqsum + zcj*zcj
        end do
        xrmsz = xsqsum/float(ngood)
        yrmsz = ysqsum/float(ngood)
        zrmsz = zsqsum/float(ngood)
        xrmsz = sqrt(xrmsz)
        yrmsz = sqrt(yrmsz)
        zrmsz = sqrt(zrmsz)
        ! select the particles in the regions and count them
        if (ityp==0) then
          ! ityp=0, the zones are defined in the 3-d space (x/a,y/b,z/c)
          do i = 1, nzone
            inzonn(i) = 0
            do j = 1, ngood
              xcp = xc(j)/xrmsz
              ycp = yc(j)/yrmsz
              zcp = zc(j)/zrmsz
              rxyz = sqrt((xcp*xcp+ycp*ycp+zcp*zcp)/3.)
              if (rxyz<frms(i+1) .and. rxyz>=frms(i)) then
                inzonn(i) = inzonn(i) + 1
                if (init==1) f(10, j) = frms(i+1)
              end if
              if (f(10,j)==100. .and. init==1) f(10, j) = 0.
            end do
            if (init==1) then
              write (16, *) inzonn(i), ' particles initially in zone ', i
            else
              write (16, *) inzonn(i), ' particles in zone ', i
            end if
          end do
        else
          ! ityp=1, the zones are defined in the plane (x/a,y/b)
          do i = 1, nzone
            inzonn(i) = 0
            do j = 1, ngood
              xcp = xc(j)/xrmsz
              ycp = yc(j)/yrmsz
              zcp = zc(j)/zrmsz
              rxyz = sqrt((xcp*xcp+ycp*ycp)/2.)
              if (rxyz<frms(i+1) .and. rxyz>=frms(i)) then
                inzonn(i) = inzonn(i) + 1
                if (init==1) f(10, j) = frms(i+1)
              end if
              if (f(10,j)==100. .and. init==1) f(10, j) = 0.
            end do
            if (init==1) then
              write (16, *) inzonn(i), ' particles initially in zone ', i
            else
              write (16, *) inzonn(i), ' particles in zone ', i
            end if
          end do
        end if
      end if
      return
    end subroutine area
    ! *******************************************************************
    ! subroutine histgrm
    ! called by plotting routine grcomp(text,iskale)
    ! *******************************************************************
    subroutine histgrm
      implicit real *8(a-h, o-z)
      parameter(iptsz=100002)
      common /faisc/f(10, iptsz), imax, ngood
      common /consta/vl, pi, xmat, rpel, qst
      common /tapes/in, ifile, meta
      common /dyn/tref, vref
      common /ttfc/tk, t1k, t2k, sk, s1k, s2k, fh
      common /part/xc(iptsz), yc(iptsz), zc(iptsz)
      common /hist/xpos(200), xn(200), ypos(200), yn(200), zpos(200), zn(200), ixt, iyt, izt
      common /hist1/xps(200), xpn(200), yps(200), ypn(200), zps(200), zpn(200), ixpt, iypt, izpt

      trmoy = 0.
      wcg = 0.
      xcg = 0.
      xcg = 0.
      ycg = 0.
      fnstp = 100.
      do i = 1, ngood
        trmoy = trmoy + f(6, i)
        wcg = wcg + f(7, i)
        xcg = xcg + f(2, i)
        ycg = ycg + f(4, i)
      end do
      trmoy = trmoy/float(ngood)
      wcg = wcg/float(ngood)
      xcg = xcg/float(ngood)
      ycg = ycg/float(ngood)
      zcg = trmoy*fh
      ! Isochronism correction (in case the bunch is not erect)
      xb2x = 0.
      xb2z = 0.
      xbxz = 0.
      imaxx = 0
      do np = 1, ngood
        gnp = f(7, np)/xmat
        vnp = vl*sqrt(1.-1./(gnp*gnp))
        zc(np) = (trmoy-f(6,np))*vnp/100.
        xc(np) = (f(2,np)-xcg)/100.
        xb2z = xb2z + zc(np)*zc(np)
        xb2x = xb2x + xc(np)*xc(np)
        xbxz = xbxz + zc(np)*xc(np)
        imaxx = imaxx + 1
      end do
      xb2z = xb2z/float(imaxx)
      xb2x = xb2x/float(imaxx)
      xbxz = xbxz/float(imaxx)
      apl = atan(-2.*xbxz/(xb2x-xb2z))/2.
      ! coordinates of the particles at the point of time position
      xbar = 0.
      ybar = 0.
      zbar = 0.
      imaxx = 0
      ! Divide by 100. to convert from centimeters to meters
      do np = 1, ngood
        gnp = f(7, np)/xmat
        vnp = vl*sqrt(1.-1./(gnp*gnp))
        znp = (trmoy-f(6,np))*vnp
        xnp = f(2, np)
        zc(np) = znp*cos(apl) + xnp*sin(apl)
        xnp = xnp*cos(apl) - znp*sin(apl)
        ! convert from mrad to rad
        f3 = f(3, np)*1.e-03
        f5 = f(5, np)*1.e-03
        ! convert from cm   to m
        xc(np) = (xnp+zc(np)*f3)/100.
        yc(np) = (f(4,np)+zc(np)*f5)/100.
        zc(np) = zc(np)/100.
        ! evaluate xbar , ybar , zbar
        xbar = xbar + xc(np)
        ybar = ybar + yc(np)
        zbar = zbar + zc(np)
      end do
      eng = float(ngood)
      xbar = xbar/eng
      ybar = ybar/eng
      zbar = zbar/eng
      do np = 1, ngood
        xc(np) = xc(np) - xbar
        yc(np) = yc(np) - ybar
        zc(np) = zc(np) - zbar
      end do
      ! evaluate the rms sizes
      xsqsum = 0.
      ysqsum = 0.
      zsqsum = 0.
      do j = 1, ngood
        xsqsum = xsqsum + xc(j)*xc(j)
        ysqsum = ysqsum + yc(j)*yc(j)
        zsqsum = zsqsum + zc(j)*zc(j)
      end do
      xrmsz = xsqsum/float(ngood)
      yrmsz = ysqsum/float(ngood)
      zrmsz = zsqsum/float(ngood)
      xrmsz = sqrt(xrmsz)
      yrmsz = sqrt(yrmsz)
      zrmsz = sqrt(zrmsz)
      ! normalize the coordinates x, y and z
      do j = 1, ngood
        xc(j) = xc(j)/xrmsz
        yc(j) = yc(j)/yrmsz
        zc(j) = zc(j)/zrmsz
      end do
      ! look for the limits of the cloud of particles in the plane (x/a, y/b, z/c)
      ! these limits are assumed included within at most +/- 5 RMS
      fract = 5.
      xinf = 0.
      yinf = 0.
      zinf = 0.
      ! lower limits
      do i = 1, ngood
        if ((abs(xc(i))<=fract) .and. (abs(yc(i))<=fract) .and. (abs(zc(i))<=fract)) then
          if (xinf>xc(i)) xinf = xc(i)
          if (yinf>yc(i)) yinf = yc(i)
          if (zinf>zc(i)) zinf = zc(i)
        end if
      end do
      ! upper limits
      xsup = xinf
      ysup = yinf
      zsup = zinf
      do i = 1, ngood
        if ((abs(xc(i))<=fract) .and. (abs(yc(i))<=fract) .and. (abs(zc(i))<=fract)) then
          if (xsup<xc(i)) xsup = xc(i)
          if (ysup<yc(i)) ysup = yc(i)
          if (zsup<zc(i)) zsup = zc(i)
        end if
      end do
      ! maximal sizes in x, y, and z-directions
      pax = (xsup-xinf)
      pay = (ysup-yinf)
      paz = (zsup-zinf)
      ! histogram in x-direction,the step (stepx) is: pax/50
      stepx = pax/fnstp
      do i = 1, 200
        xn(i) = 0.
      end do
      xtot = 0.
      x0 = xinf - stepx
      x1 = x0 + stepx
      j = 1
150   continue
      ! xpos(j): position of the elementary cylinder j
      ! xn(j)  : number of particles in the elementary cylinder j
      ! xtot   : total number of particles in x-direction
      if (x1>xsup+stepx) go to 160
      do i = 1, ngood
        if (xc(i)>x0 .and. xc(i)<=x1) xn(j) = xn(j) + 1.
      end do
      xtot = xtot + xn(j)
      xpos(j) = x0 + stepx/2.
      j = j + 1
      sta = x1
      x1 = x1 + stepx
      x0 = sta
      go to 150
160   continue
      ! normalize the number of particles in each step with regard to max.(xn(j))
      j = j - 1
      ixt = j
      xnor = 0.
      do i = 1, j
        if (xnor<xn(i)) xnor = xn(i)
      end do
      do i = 1, j
        xn(i) = xn(i)/xnor
      end do
      ! histogram in y-direction,the step (stepy) is: pay/50
      stepy = pay/fnstp
      do i = 1, 200
        yn(i) = 0.
      end do
      ytot = 0.
      y0 = yinf - stepy
      y1 = y0 + stepy
      j = 1
      ! ypos(j): position of the step j
      ! yn(j)  : number of particles lying in the  j
      ! ytot   : total number of particles in y-direction
151   continue
      if (y1>ysup+stepy) go to 161
      do i = 1, ngood
        if (yc(i)>y0 .and. yc(i)<=y1) yn(j) = yn(j) + 1.
      end do
      ytot = ytot + yn(j)
      ypos(j) = y0 + stepy/2.
      j = j + 1
      sta = y1
      y1 = y1 + stepy
      y0 = sta
      go to 151
161   continue
      j = j - 1
      iyt = j
      y0 = yinf
      ! normalize the number of particles in step with regard to max(yn(j))
      ynor = 0.
      do i = 1, j
        if (ynor<yn(i)) ynor = yn(i)
      end do
      do i = 1, j
        yn(i) = yn(i)/ynor
      end do
      ! histogram in z-direction,the step (stepz) is: paz/50
      do i = 1, 200
        zn(i) = 0.
      end do
      stepz = paz/fnstp
      ztot = 0.
      z0 = zinf - stepz
      z1 = z0 + stepz
      j = 1
      ! of length :stepz and radius:ray
      ! zpos(j): position of the step j
      ! zn(j)  : number of particles in the step j
      ! ztot   : total number of particles in z-direction
152   continue
      if (z1>zsup+2.*stepz) go to 162
      do i = 1, ngood
        if (zc(i)>z0 .and. zc(i)<=z1) zn(j) = zn(j) + 1.
      end do
      ztot = ztot + zn(j)
      zpos(j) = z0 + stepz/2.
      j = j + 1
      sta = z1
      z1 = z1 + stepz
      z0 = sta
      go to 152
162   continue
      j = j - 1
      izt = j
      ! *et*2011 added next line
      z0 = zinf
      ! normalize the number of particles in each step with regard to max(zn(j))
      znor = 0.
      do i = 1, j
        if (znor<zn(i)) znor = zn(i)
      end do
      do i = 1, j
        zn(i) = zn(i)/znor
      end do
      ! look for the limits of xp, yp, zp
      xpinf = f(3, 1)
      ypinf = f(5, 1)
      zpinf = f(6, 1) - trmoy
      ! lower limits
      do i = 1, ngood
        f3 = f(3, i)
        f5 = f(5, i)
        f6 = f(6, i) - trmoy
        if (xpinf>f3) xpinf = f3
        if (ypinf>f5) ypinf = f5
        if (zpinf>f6) zpinf = f6
      end do
      ! upper limits
      xpsup = xpinf
      ypsup = ypinf
      zpsup = zpinf
      do i = 1, ngood
        f3 = f(3, i)
        f5 = f(5, i)
        f6 = f(6, i) - trmoy
        if (xpsup<f3) xpsup = f3
        if (ypsup<f5) ypsup = f5
        if (zpsup<f6) zpsup = f6
      end do
      ! maximal sizes in xp, yp, and zp-directions
      paxp = (xpsup-xpinf)
      payp = (ypsup-ypinf)
      pazp = (zpsup-zpinf)
      ! evaluate the rms sizes in xp, yp, zp
      xpsum = 0.
      ypsum = 0.
      zpsum = 0.
      do i = 1, ngood
        f3 = f(3, i)
        f5 = f(5, i)
        f6 = f(6, i) - trmoy
        xpsum = xpsum + f3*f3
        ypsum = ypsum + f5*f5
        zpsum = zpsum + f6*f6
      end do
      xpsum = xpsum/float(ngood)
      ypsum = ypsum/float(ngood)
      zpsum = zpsum/float(ngood)
      xpsum = sqrt(xpsum)
      ypsum = sqrt(ypsum)
      zpsum = sqrt(zpsum)
      ! histogram in xp-direction,the step (stxp) is: paxp/50
      stpx = paxp/fnstp
      do i = 1, 200
        xpn(i) = 0.
      end do
      xp0 = xpinf - stpx
      xp1 = xp0 + stpx
      j = 1
250   continue
      ! xps(j): position of the step j
      ! xpn(j): number of particles lying in the step j
      if (xp1>xpsup+stpx) go to 260
      do i = 1, ngood
        if (f(3,i)>xp0 .and. f(3,i)<=xp1) xpn(j) = xpn(j) + 1.
      end do
      xps(j) = xp0 + stpx/2.
      j = j + 1
      sta = xp1
      xp1 = xp1 + stpx
      xp0 = sta
      go to 250
260   continue
      ! normalize the number of particles in each step with regard to max.(xpn(j))
      j = j - 1
      ixpt = j
      xnor = 0.
      do i = 1, j
        if (xnor<xpn(i)) xnor = xpn(i)
      end do
      do i = 1, j
        xpn(i) = xpn(i)/xnor
        xps(i) = xps(i)/xpsum
      end do
      ! histogram in yp-direction,the step (stpy) is: payp/50
      stpy = payp/fnstp
      do i = 1, 200
        ypn(i) = 0.
      end do
      yp0 = ypinf - stpy
      yp1 = yp0 + stpy
      j = 1
      ! yps(j): position of the step j in mrd
      ! ypn(j)  : number of particles lying in the  j
251   continue
      if (yp1>ypsup+stpy) go to 261
      do i = 1, ngood
        if (f(5,i)>yp0 .and. f(5,i)<=yp1) ypn(j) = ypn(j) + 1.
      end do
      yps(j) = yp0 + stpy/2.
      j = j + 1
      sta = yp1
      yp1 = yp1 + stpy
      yp0 = sta
      go to 251
261   continue
      j = j - 1
      iypt = j
      yp0 = ypinf
      ! normalize the number of particles in step with regard to max(ypn(j))
      ynor = 0.
      do i = 1, j
        if (ynor<ypn(i)) ynor = ypn(i)
      end do
      do i = 1, j
        ypn(i) = ypn(i)/ynor
        yps(i) = yps(i)/ypsum
      end do
      ! histogram in zp-direction,the step (stpz) is: pazp/50
      do i = 1, 200
        zpn(i) = 0.
      end do
      stpz = pazp/fnstp
      zp0 = zpinf - stpz
      zp1 = zp0 + stpz
      j = 1
      ! of length :stepz and radius:ray
      ! zps(j): position of the step j (deg)
      ! zpn(j)  : number of particles in the step j
252   continue
      if (zp1>zpsup+2.*stpz) go to 262
      do i = 1, ngood
        f6 = f(6, i) - trmoy
        if (f6>zp0 .and. f6<=zp1) zpn(j) = zpn(j) + 1.
      end do
      zps(j) = zp0 + stpz/2.
      j = j + 1
      sta = zp1
      zp1 = zp1 + stpz
      zp0 = sta
      go to 252
262   continue
      ! normalize the number of particles in each step with regard to max(zn(j))
      j = j - 1
      izpt = j
      zpnor = 0.
      do i = 1, j
        if (zpnor<zpn(i)) zpnor = zpn(i)
      end do
      do i = 1, j
        zpn(i) = zpn(i)/zpnor
        zps(i) = zps(i)/zpsum
      end do
      return
    end subroutine histgrm
    ! *******************************************************************
    ! SUBROUTINE daves
    ! Write the characteristics of the beam to the disk

    ! ---- statistics (dE-dPHI)
    ! dav1(i,10) :  extension of phase  dPHI (deg)
    ! dav1(i,11) :  dispersion of energy dE (MeV)
    ! dav1(i,12) :  emittance (MeV*rad)
    ! dav1(i,23) :  correlation  between dE an dPHI

    ! ---- statistics (x-xp)

    ! dav1(i,13): x-extension (mm)
    ! dav1(i,14): xp-extension (mrad)
    ! dav1(i,15): correlation between x and xp
    ! dav1(i,16): Emittance(norm)  x-xp (mm*mrad)
    ! dav1(i,17): Emittance(non norm) x-xp (mm*mrad)

    ! ---- statistics (y-yp)
    ! dav1(i,18): y-extension  (mm)
    ! dav1(i,19): yp-extension (mrad)
    ! dav1(i,20): correlation between y and yp
    ! dav1(i,21) : Emittance(norm) y-yp (mm*mrad)
    ! dav1(i,22) : Emittance(non norm) y-yp (mm*mrad)

    ! with CHASE These parameters are in the array dav2 like above
    ! *******************************************************************
    subroutine daves
      implicit real *8(a-h, o-z)
      parameter(iptsz=100002, maxcell=3000, maxcell1=3000)
      common /consta/vl, pi, xmat, rpel, qst
      common /faisc/f(10, iptsz), imax, ngood
      common /speda/dave, idave
      common /davcom/dav1(maxcell1, 40), davtot, iitem(maxcell1), idav
      common /etcha1/dav2(maxcell1, 33), ichas(iptsz), chasit
      common /etcom/cog(8), exten(17), fd(iptsz)
      common /sc3/beamc, scdist, sce10, cplm, ect, apl, ichaes, iscsp
      common /cptemit/xltot(maxcell1), nbemit
      common /poro/irot1, irot2
      logical irot1, irot2
      common /secdr/iseor
      common /itvole/itvol, imamin
      common /dyni/vrefi, trefi, fhinit, acpt
      common /qfkd/ityq
      common /shortl/davprt
      logical iseor
      logical dave, chasit, ichaes, itvol, imamin, ityq
      character *80 davprt(maxcell1)
      ! dave end
      write (12, 3334)
3334  format ('*****************************************************')
      ! 34     FORMAT(10A8)
      ! ********************************************************************
      write (12, *) ' Energies are in [MeV], phases in [deg]', ' lengths in [mm] ,tof in [deg]'
      write (12, *) ' ** For lenses followed by :', ' Cummulative length, element type, length '

      write (12, *) ' ** For emit followed by'
      write (12, *) ' * Line 1:', ' Particle reference:  beta, energy, tof ', &
        '  COG: energy, tof, energy offset, tof offset'
      write (12, *) ' * Line 2:', ' COG coordinates for x  xp  y  yp (mm and mrad)'
      write (12, *) ' * Line 3:', ' alpha-x beta-x(mm/mrad) alpha-y beta-y(mm/mrad)', ' alpha-z beta-z(ns/keV)'
      write (12, *) ' * Line 4:', ' alpha-z beta-z(deg/keV) emit-z(non norm.,keV.deg) f(MHz)'
      write (12, *) ' * Line 5:', ' dPHI(deg)  dW(keV)   r12   long. emittance', '  (keV.ns) particles left'
      write (12, *) ' * Line 6:', '   x(mm)    xp(mrad)  r12   hor.  emittance', '  (norm & non norm, mm.mrad)'
      write (12, *) ' * Line 7:', '   y(mm)    yp(mrad)  r12   vert. emittance', '  (norm & non norm, mm.mrad)'
      ! ********************************************************************
      write (12, 3334)
      write (12, *) '            Simulation with ', imax, ' particles'
      if (iseor) then
        write (12, *) '            Second order transport matrix    '
      else
        write (12, *) '            First order transport matrix    '
      end if
      if (ichaes) then
        write (12, *) '            Beam intensity  ', beamc, ' mA'
        if (iscsp==1) write (12, *) '            Space charge calculations with HERSC   '
        if (iscsp==2) write (12, *) '            Space charge calculations with SCHERM  '
        if (iscsp==3 .or. iscsp==4) write (12, *) '            Space charge calculations with SCHEFF  '
        if (sce10==1) write (12, *) &
          'Space charge calculated for all relevant elements,                but not at drifts'
        if (sce10==2) write (12, *) 'Space charge calculated for accelerating elements only'
        if (sce10==3) write (12, *) 'Space charge calculated for all relevant elements'
      end if
      if (itvol) write (12, *) ' TOF is operational in accelerating elements  '
      if (imamin) write (12, *) 'Phase adjustments for accelerating elements active'
      write (12, 3334)
      ifirst = 1
      iit6 = 0
      nemit = 0
      do i = 1, idav
        if (davprt(i)/='') write (12, '(A)') davprt(i)
        if (iitem(i)==1) then
          ! cavity
          n = int(dav1(i,25)+.5)
          if (itvol .and. imamin) then
            write (12, 1000) dav1(i, 24), n, dav1(i, 1), dav1(i, 38), dav1(i, 39)
1000        format (f9.2, ' mm Cavity ', i3, ' length ', f7.2, ' mm', /, ' phase offset: before adjustement ', e12.5, &
              ' deg', ' after adjustement ', e14.7, ' deg')
          else
            write (12, 2789) dav1(i, 24), n, dav1(i, 1), dav1(i, 38)
          end if
2789      format (f9.2, ' mm Cavity ', i3, ' length ', f7.2, ' mm', ' phase offset: ', e12.5, ' deg')
        end if

        if (iitem(i)==2) then
          ! quadrupole (magnetic)
          write (12, 1010) dav1(i, 4), dav1(i, 1), dav1(i, 7), dav1(i, 2), dav1(i, 3), dav1(i, 5), dav1(i, 6), &
            dav1(i, 36)
1010      format (f9.2, ' mm  Quadrupole:  length = ', e12.5, ' mm', '  aperture radius = ', e12.5, ' mm', /, &
            '   field = ', e12.5, ' kG  K2 = ', e12.5, ' cm-2 gradient = ', e12.5, ' kG/cm', /, '   momentum = ', e12.5, &
            ' kG.cm  particles left  ', f7.0)
          write (12, *)
        end if

        if (iitem(i)==3) then
          ! emiprt
          write (12, 305)
305       format ('**********          beam (emit card)         ', '**********')
          nemit = nemit + 1
          ! omment         write(13,556) nemit,xltot(nemit)/100.,dav1(i,12)*1000.,
          ! omment     *                 dav1(i,6),dav1(i,30)
          ! omment         write(14,557) nemit,xltot(nemit)/100.,dav1(i,16),dav1(i,21)
          ! omment556      format(2x,i3,3(3x,f8.3),3x,f6.0)
          ! omment557      format(2x,i3,3(3x,f8.3))
          ! ****************************************
          write (12, 1001)(dav1(i,j), j=3, 9)
1001      format (2x, f7.5, 4(1x,e14.7), 2(2x,e12.5), ' MeV-deg')
          write (12, 2003)(dav1(i,j), j=31, 34)
2003      format (4(2x,f7.3), ' mm and mrad ')
          ! --- following lines describe Courant-Snyder parameters
          fh = dav1(i, 40)
          ! 1)  alpz betz

          ! 1-a) emz: emittance (keV*deg) betz(deg/keV)  gamz(keV/deg)
          emz = dav1(i, 12)*1000.*(180./pi)
          betz = 0.
          if (emz>1.e-10) betz = dav1(i, 10)*dav1(i, 10)/emz
          dez = dav1(i, 11)*1000.
          gamz = 0.
          if (emz>1.e-10) gamz = dez*dez/emz
          alpz = 0.
          if (betz*gamz>=1.) alpz = sqrt(betz*gamz-1.)
          if (dav1(i,23)>0.) alpz = -alpz

          ! 1-b) emzz: emittance dE-dphi (keV*ns) betzz(ns/keV) gamzz(keV/ns)
          emzz = 1.e12*dav1(i, 12)/fh
          dphizz = 1.e09*dav1(i, 10)/fh*(pi/180.)
          betzz = 0.
          if (emzz>1.e-10) betzz = dphizz*dphizz/emzz
          gamzz = 0.
          if (emzz>1.e-10) gamzz = dez*dez/emzz
          alpzz = 0.
          if (betzz*gamzz>=1.) alpzz = sqrt(betzz*gamzz-1.)
          if (dav1(i,23)>0.) alpzz = -alpzz

          ! 2)  alpx btx
          ! betx(mm/mrad)  gamx (mrad/mm)
          betx = 0.
          emx = dav1(i, 17)
          if (emx>1e-10) betx = dav1(i, 13)*dav1(i, 13)/emx
          gamx = 0.
          if (emx>1e-10) gamx = dav1(i, 14)*dav1(i, 14)/emx
          alpx = 0.
          if (betx*gamx>=1.) alpx = sqrt(betx*gamx-1.)
          if (dav1(i,15)>0.) alpx = -alpx

          ! 3)  alpy bety
          ! bety(mm/mrad)  gamy (mrad/mm)
          bety = 0.
          emy = dav1(i, 22)
          if (emy>1e-10) bety = dav1(i, 18)*dav1(i, 18)/emy
          gamy = 0.
          if (emy>1e-10) gamy = dav1(i, 19)*dav1(i, 19)/emy
          alpy = 0.
          if (bety*gamy>=1.) alpy = sqrt(bety*gamy-1.)
          if (dav1(i,20)>0.) alpy = -alpy

          ! betzz: ns/keV
          write (12, 3213) alpx, betx, alpy, bety, alpzz, betzz
3213      format (3(2x,e12.5,2x,e12.5), 2x, e12.5)
          ! emittance (keV*deg) betz(deg/keV)
          write (12, 597) alpz, betz, emz, fh/(2.*pi*1.e6)
597       format (2x, f8.4, 2x, e13.6, 2x, e13.6, ' keV.deg', 2x, f8.3, ' MHz')
          if (emzz>1000.) then
            ! ns.MeV
            write (12, 6332) dav1(i, 10), dez, dav1(i, 23), emzz/1000., dav1(i, 30)
6332        format (2x, f7.3, 1x, f10.2, 2x, f8.4, 3x, f8.3, ' ns.MeV   ', f7.0, ' particles left')
          else
            ! ns.keV
            write (12, 1002) dav1(i, 10), dez, dav1(i, 23), emzz, dav1(i, 30)
1002        format (2x, e12.5, 2x, f7.2, 2x, f8.4, 2x, f7.3, ' ns.keV   ', f7.0, ' particles left')
          end if
          write (12, 1003)(dav1(i,j), j=13, 22)
1003      format (2(2x,f7.3,3x,f8.3,2x,f8.4,2x,e12.5,' mm.mrad (norm)',2x,f7.3,' (non norm)',/))
          write (12, *)
          if (dav1(i,26)==1.) then
            write (12, 8333)(dav2(i,j), j=31, 33)
8333        format ('********** With chase', 3(1x,f6.4), ' **********')
            write (12, 1001)(dav1(i,j), j=3, 9)
            write (12, 2003)(dav2(i,j), j=26, 29)
            ! following lines describe Courant-Snyder parameters
            ! 1)  alpz betz

            ! 1-a) emz: emittance (keV*deg) betz(deg/keV)  gamz(keV/deg)
            emz = dav2(i, 12)*1000.*(180./pi)
            betz = 0.
            if (emz>1.e-10) betz = dav2(i, 10)*dav2(i, 10)/emz
            dez = dav2(i, 11)*1000.
            gamz = 0.
            if (emz>1.e-10) gamz = dez*dez/emz
            alpz = 0.
            if (betz*gamz>=1.) alpz = sqrt(betz*gamz-1.)
            if (dav2(i,23)>0.) alpz = -alpz

            ! 1-b) emzz: emittance dE-dphi (keV*ns) betzz(ns/keV) gamzz(keV/ns)
            emzz = 1.e12*dav2(i, 12)/fh
            dphizz = 1.e09*dav2(i, 10)/fh*(pi/180.)
            betzz = 0.
            if (emzz>1.e-10) betzz = dphizz*dphizz/emzz
            gamzz = 0.
            if (emzz>1.e-10) gamzz = dez*dez/emzz
            alpzz = 0.
            if (betzz*gamzz>=1.) alpzz = sqrt(betzz*gamzz-1.)
            if (dav2(i,23)>0.) alpzz = -alpzz

            ! 2)  alpx btx
            ! betx(mm/mrad)  gamx (mrad/mm)
            betx = 0.
            emx = dav1(i, 17)
            if (emx>1e-10) betx = dav2(i, 13)*dav2(i, 13)/emx
            gamx = 0.
            if (emx>1e-10) gamx = dav2(i, 14)*dav2(i, 14)/emx
            alpx = 0.
            if (betx*gamx>=1.) alpx = sqrt(betx*gamx-1.)
            if (dav2(i,15)>0.) alpx = -alpx

            ! 3)  alpy bety
            ! bety(mm/mrad)  gamy (mrad/mm)
            bety = 0.
            emy = dav2(i, 22)
            if (emy>1e-10) bety = dav2(i, 18)*dav2(i, 18)/emy
            gamy = 0.
            if (emy>1e-10) gamy = dav2(i, 19)*dav2(i, 19)/emy
            alpy = 0.
            if (bety*gamy>=1.) alpy = sqrt(bety*gamy-1.)
            if (dav2(i,20)>0.) alpy = -alpy

            ! betzz: ns/keV
            write (12, 3213) alpx, betx, alpy, bety, alpzz, betzz
            if (emzz>1000.) then
              ! ns.MeV
              write (12, 6332) dav2(i, 10), dez, dav2(i, 23), emzz/1000., dav2(i, 30)
            else
              ! ns.keV
              write (12, 1002) dav2(i, 10), dez, dav2(i, 23), emzz, dav2(i, 30)
            end if
            ifirst = 0
            ! omment           write(15,1556) nemit,xltot(nemit)/100.,dav2(i,12)*1000.
            ! omment1556       format(2x,i3,2(3x,f8.3))
            ! omment           write(18,1557) nemit,xltot(nemit)/100.,dav2(i,16),dav2(i,21)
            ! omment1557       format(2x,i3,3(3x,f8.3))
            ! omment656        format(2x,i3,3x,f7.3)
            write (12, 1003)(dav2(i,j), j=13, 22)
            write (12, *)
          end if
        end if
        if (iitem(i)==4) then
          ! bending magnet
          write (12, 1025) dav1(i, 4), dav1(i, 1), dav1(i, 2), dav1(i, 3)
1025      format (f9.2, ' mm bending magnet: central trajectory: ', f8.2, ' mm', /, '     bend angle: ', f7.3, &
            ' deg bending radius: ', e12.5, ' mm')
          write (12, 1029) dav1(i, 16), dav1(i, 14), dav1(i, 15)
1029      format ('     field: ', f7.3, ' T  n: ', f8.3, ' beta: ', f8.3)
          write (12, 1026) dav1(i, 6), dav1(i, 9), dav1(i, 7), dav1(i, 8), dav1(i, 5)
1026      format ('  *Entrance ', /, '     pole-face rotation:', f8.3, '  deg curvature: ', f8.3, ' mm', /, &
            '     fringe field corrections: K1 ', f8.3, ' K2 ', f8.3, /, '     vertical half-aperture: ', f8.3, ' mm')
          write (12, 1027) dav1(i, 10), dav1(i, 13), dav1(i, 11), dav1(i, 12), dav1(i, 17)
1027      format ('   *Exit ', /, '     pole-face rotation  :', f8.3, ' deg  curvature: ', f8.3, ' mm', /, &
            '      fringe field correction: K1 ', f7.3, ' K2 ', f7.3, /, '      vertical half-aperture: ', f8.3, ' mm')
          write (12, 1028) dav1(i, 37)
1028      format ('  particles left  ', f7.0)
          write (12, *)
        end if
        if (iitem(i)==5) then
          ! solenoid
          write (12, 5010) dav1(i, 4), dav1(i, 1), dav1(i, 2), dav1(i, 3), dav1(i, 5), dav1(i, 36)
5010      format (f9.2, ' mm  Solenoid:  length = ', f8.3, ' mm', '   field = ', e12.5, ' kG  K = ', e12.5, ' cm-1', /, &
            '      momentum = ', e12.5, ' kG.cm   particles left ', f7.0)
          write (12, *)
        end if
        if (iitem(i)==6) then
          ! From adjust or from entre(not yet introduced) input beam reference
          write (12, 303)
303       format ('**********     INITIAL BEAM          **********')
          write (12, 2003)(dav1(i,j), j=31, 34)
          ! 1)  alpz betz

          ! 1-a) emz: emittance (keV*deg) betz(deg/keV)  gamz(keV/deg)
          emz = dav1(i, 12)*1000.*(180./pi)
          betz = 0.
          if (emz>1.e-10) betz = dav1(i, 10)*dav1(i, 10)/emz
          dez = dav1(i, 11)*1000.
          gamz = 0.
          if (emz>1.e-10) gamz = dez*dez/emz
          alpz = 0.
          if (betz*gamz>=1.) alpz = sqrt(betz*gamz-1.)

          ! 1-b) emzz: emittance dE-dphi (keV*ns) betzz(ns/keV) gamzz(keV/ns)
          emzz = 1.e12*dav1(i, 12)/fhinit
          dphizz = 1.e09*dav1(i, 10)/fhinit*(pi/180.)
          betzz = 0.
          if (emzz>1.e-10) betzz = dphizz*dphizz/emzz
          gamzz = 0.
          if (emzz>1.e-10) gamzz = dez*dez/emzz
          alpzz = 0.
          if (betzz*gamzz>=1.) alpzz = sqrt(betzz*gamzz-1.)

          ! 2)  alpx btx
          ! betx(mm/mrad)  gamx (mrad/mm)
          betx = 0.
          emx = dav1(i, 17)
          if (emx>1e-10) betx = dav1(i, 13)*dav1(i, 13)/emx
          gamx = 0.
          if (emx>1e-10) gamx = dav1(i, 14)*dav1(i, 14)/emx
          alpx = 0.
          if (betx*gamx>=1.) alpx = sqrt(betx*gamx-1.)

          ! 3)  alpy bety
          ! bety(mm/mrad)  gamy (mrad/mm)
          bety = 0.
          emy = dav1(i, 22)
          if (emy>1e-10) bety = dav1(i, 18)*dav1(i, 18)/emy
          gamy = 0.
          if (emy>1e-10) gamy = dav1(i, 19)*dav1(i, 19)/emy
          alpy = 0.
          if (bety*gamy>=1.) alpy = sqrt(bety*gamy-1.)

          ! betzz: ns/keV
          write (12, 3213) alpx, betx, alpy, bety, alpzz, betzz
          fh = dav1(i, 40)
          ! emittance (keV*deg) betz(deg/keV)
          write (12, 597) alpz, betz, emz, fh/(2.*pi*1.e6)
          if (emzz>1000.) then
            ! ns.MeV
            write (12, 6332) dav1(i, 10), dez, dav1(i, 23), emzz/1000., dav1(i, 30)
          else
            ! ns.keV
            write (12, 1002) dav1(i, 10), dez, dav1(i, 23), emzz, dav1(i, 30)
          end if
          write (12, 1003)(dav1(i,j), j=13, 22)
          iit6 = 1
          write (12, 304)
304       format ('**********            With chase             ', '**********')
          write (12, 2003)(dav2(i,j), j=26, 29)
          ! 1)  alpz betz

          ! 1-a) emz: emittance (keV*deg) betz(deg/keV)  gamz(keV/deg)
          emz = dav2(i, 12)*1000.*(180./pi)
          betz = 0.
          if (emz>1.e-10) betz = dav2(i, 10)*dav2(i, 10)/emz
          dez = dav2(i, 11)*1000.
          gamz = 0.
          if (emz>1.e-10) gamz = dez*dez/emz
          alpz = 0.
          if (betz*gamz>=1.) alpz = sqrt(betz*gamz-1.)

          ! 1-b) emzz: emittance dE-dphi (keV*ns) betzz(ns/keV) gamzz(keV/ns)
          emzz = 1.e12*dav2(i, 12)/fh
          dphizz = 1.e09*dav2(i, 10)/fh*(pi/180.)
          betzz = 0.
          if (emzz>1.e-10) betzz = dphizz*dphizz/emzz
          gamzz = 0.
          if (emzz>1.e-10) gamzz = dez*dez/emzz
          alpzz = 0.
          if (betzz*gamzz>=1.) alpzz = sqrt(betzz*gamzz-1.)

          ! 2)  alpx btx
          ! betx(mm/mrad)  gamx (mrad/mm)
          betx = 0.
          emx = dav1(i, 17)
          if (emx>1e-10) betx = dav2(i, 13)*dav2(i, 13)/emx
          gamx = 0.
          if (emx>1e-10) gamx = dav2(i, 14)*dav2(i, 14)/emx
          alpx = 0.
          if (betx*gamx>=1.) alpx = sqrt(betx*gamx-1.)

          ! 3)  alpy bety

          ! bety(mm/mrad)  gamy (mrad/mm)
          bety = 0.
          emy = dav2(i, 22)
          if (emy>1e-10) bety = dav2(i, 18)*dav2(i, 18)/emy
          gamy = 0.
          if (emy>1e-10) gamy = dav2(i, 19)*dav2(i, 19)/emy
          alpy = 0.
          if (bety*gamy>=1.) alpy = sqrt(bety*gamy-1.)

          ! betzz: ns/keV
          write (12, 3213) alpx, betx, alpy, bety, alpzz, betzz
          if (emzz>1000.) then
            ! ns.MeV
            write (12, 6332) dav2(i, 10), dez, dav2(i, 23), emzz/1000., dav2(i, 30)
          else
            ! ns.keV
            write (12, 1002) dav2(i, 10), dez, dav2(i, 23), emzz, dav2(i, 30)
          end if
          ifirst = 0
          write (12, 1003)(dav2(i,j), j=13, 22)
          write (12, *)
        end if
        if (iitem(i)==7) then
          ! drift
          write (12, 7010) dav1(i, 4), dav1(i, 1), dav1(i, 36)
7010      format (f9.2, ' mm  Drift:  length ', f10.3, ' mm ', /, '   particles left  ', f7.0)
          write (12, *)
        end if
        if (iitem(i)==8) then
          ! buncher
          if (.not. imamin) write (12, 8010) dav1(i, 4), dav1(i, 1), dav1(i, 2), dav1(i, 3), dav1(i, 36)
8010      format (f9.2, ' mm  Buncher ', f9.3, ' MV ', '  RF Phase ', f9.3, ' deg  Aperture radius', f5.1, ' cm', /, &
            '   particles left  ', f7.0)
          if (imamin) write (12, 8110) dav1(i, 4), dav1(i, 1), dav1(i, 2), dav1(i, 5), dav1(i, 3), dav1(i, 36)
8110      format (f9.2, ' mm  Buncher ', f9.3, ' MV ', '  RF Phase ', f9.3, ' deg correction ', f9.3, ' deg', &
            '  Aperture radius', f5.1, ' cm', /, '   particles left  ', f7.0)
          write (12, *)
        end if
        if (iitem(i)==9) then
          ! steerer
          if (dav1(i,2)==0.) then
            write (12, 8020) dav1(i, 3), dav1(i, 1)
8020        format (f9.2, ' mm  Hor. Mag. Steerer ', e12.5, ' Tm ')
          else if (dav1(i,2)==1.) then
            write (12, 8021) dav1(i, 3), dav1(i, 1)
8021        format (f9.2, ' mm  Ver. Mag. Steerer ', f12.5, ' Tm ')
          else if (dav1(i,2)==2.) then
            write (12, 8022) dav1(i, 3), dav1(i, 1)
8022        format (f9.2, ' mm  Hor. El. Steerer ', e12.5, ' kVm/m ')
          else if (dav1(i,2)==3.) then
            write (12, 8023) dav1(i, 3), dav1(i, 1)
8023        format (f9.2, ' mm  Ver. El. Steerer ', e12.5, ' kVm/m ')
          end if
          write (12, *)
        end if
        if (iitem(i)==10) then
          ! sextupole
          write (12, 1011) dav1(i, 4), dav1(i, 1), dav1(i, 6), dav1(i, 3), dav1(i, 5), dav1(i, 2), dav1(i, 7), &
            dav1(i, 36)
1011      format (f9.2, ' mm  Sextupole:  length = ', f7.3, ' mm', '  aperture radius = ', e12.5, ' cm', /, &
            '   field = ', e12.5, ' kG  KS2 = ', e12.5, ' cm-3', '   gradient = ', e12.5, ' kG/cm2', /, &
            '   momentum = ', e12.5, ' kG.cm   particles left  ', f7.0)
          write (12, *)
        end if
        if (iitem(i)==11) then
          ! solenoid+quadrupole
          write (12, 5011) dav1(i, 4), dav1(i, 1), dav1(i, 7), dav1(i, 2), dav1(i, 6), dav1(i, 3), dav1(i, 5), &
            dav1(i, 8), dav1(i, 36)
5011      format (f9.2, ' mm Sol+Quad: length = ', f7.3, ' mm aperture radius= ', e12.5, ' mm', /, &
            ' Solenoid: field = ', e12.5, ' kG  K = ', e12.5, ' cm-1', /, ' Quadrupole: field ', e12.5, ' kG  K2 = ', &
            e12.5, ' cm-2', /, ' momentum = ', e12.5, ' kG.cm   particles left ', f7.0)
          write (12, *)
        end if
        if (iitem(i)==12) then
          ! quadrupole + sextupole
          write (12, 5021) dav1(i, 4), dav1(i, 1), dav1(i, 6), dav1(i, 2), dav1(i, 3), dav1(i, 7), dav1(i, 8), &
            dav1(i, 10), dav1(i, 36)
5021      format (f9.2, ' mm  Quad+Sext: length = ', e12.5, ' mm ', ' aperture radius = ', e12.5, ' mm', /, &
            '  Quadrupole: B = ', e12.5, ' kG  K2 = ', e12.5, ' cm-2', /, '  Sextupole:  B = ', e12.5, ' kG  K2 = ', &
            e12.5, ' cm-3', /, ' momentum = ', e12.5, ' kG.cm   particles left ', f7.0)
          write (12, *)
        end if
        if (iitem(i)==13) then
          ! electron gun
          write (12, 5031) dav1(i, 4), dav1(i, 1), dav1(i, 2), dav1(i, 3), dav1(i, 6), dav1(i, 36)
5031      format (f9.2, ' mm  DC egun  length:', f7.3, ' mm', /, ' Crest field:', f8.3, ' MV/m', 3x, ' field stength:', &
            f8.3, ' kV', /, ' beta ( output):', e12.5, ' particles left ', f7.0)
          ! 14/01/2010         write(12,5032) dav1(i,5),dav1(i,7)
          ! 14/10/2010 5032     format(' beam (emit card) at ',e12.5,
          ! 14/10/2010     *          ' mm from the cathode, field (MV/m) ',e12.5)
          write (12, *)
        end if
        ! rfqcl (RFQ cell)
        if (iitem(i)==14) then
          ncell = int(dav1(i,7))
          write (12, 5041) dav1(i, 4), ncell, dav1(i, 1), dav1(i, 2), dav1(i, 3), dav1(i, 5), dav1(i, 6), dav1(i, 36)
5041      format (f9.2, ' mm rfq cell:', i5, ' length: ', f7.3, ' mm', /, '  V/r02: ', e12.5, ' kV/mm**2  AV:', e12.5, &
            ' kV ', '  type: ', f3.0, /, '  energy(output): ', e12.5, ' MeV ', '  particles left ', f7.0)
          write (12, *)
        end if
        ! rfqptq (RFQ)
        if (iitem(i)==15) then
          ncell = int(dav1(i,7))
          write (12, 5042) dav1(i, 4), ncell, dav1(i, 5), dav1(i, 9), dav1(i, 8), dav1(i, 6), dav1(i, 36)
5042      format (f9.2, ' mm rfq: number of cells:', i5, ' total length: ', e12.5, ' mm', /, &
            '  intervane voltage (reference): ', e12.5, ' kV', /, '  intervane voltage (bunch): ', e12.5, ' kV', /, &
            '  energy (output): ', e12.5, ' MeV', /, '  particles left ', f7.0)
          write (12, *)
        end if
        ! stipper foils
        if (iitem(i)==16) then
          write (12, 5043) dav1(i, 4), dav1(i, 1), dav1(i, 2), dav1(i, 3), dav1(i, 5), dav1(i, 6), dav1(i, 36)
5043      format (f9.2, ' mm stripper: atomic number: ', f4.0, '   atomic mass : ', f4.0, '  thickness :', e12.5, &
            ' g/cm**2', /, 4x, 'particles charge : ', f4.0, 2x, 'energy loss: ', e12.5, ' MeV', /, &
            '    particles left ', f7.0)
          write (12, *)
        end if
        ! accelerating gap
        if (iitem(i)==17) then
          n = int(dav1(i,25)+.5)
          ! 16/12/09         if(itvol.and.imamin) then
          ! 16/12/09          write(12,1009) dav1(i,24),n,dav1(i,1),dav1(i,2),
          ! 16/12/09     *                   dav1(i,38),dav1(i,39)
          ! 16/12/09 1009     format(f9.2,' mm Ac. gap ',i3,' length ',f7.2,
          ! 16/12/09     *                 'mm field ',e12.5,' kV/mm',/,
          ! 16/12/09     *   '    phase offset adjusted with TOF',/,
          ! 16/12/09     *   '    before adjustement ',e12.5,' deg',
          ! 16/12/09     *   ' after adjustement ',e14.7,' deg')
          ! 16/12/09         else
          write (12, 1008) dav1(i, 24), n, dav1(i, 1), dav1(i, 2), dav1(i, 38)
          ! 16/12/09         endif
1008      format (f9.2, ' mm Ac. gap ', i3, ' length ', f7.2, ' mm field ', e12.5, ' kV/mm  phase of RF (middle): ', &
            e12.5, ' deg')
          write (12, *)
        end if
        ! QUAELEC electric quadrupole
        if (iitem(i)==18) then
          write (12, 2010) dav1(i, 4), dav1(i, 1), dav1(i, 7), dav1(i, 2), dav1(i, 6), dav1(i, 5), dav1(i, 3), &
            dav1(i, 36)
2010      format (f9.2, ' mm  Quadrupole (electric): length = ', e12.5, ' mm aperture radius = ', e12.5, ' mm', /, &
            '  voltage = ', f8.3, ' kV  K2 = ', e12.5, ' cm-2  gradient = ', e12.5, ' kV/(cm*cm) ', /, '  rigidity = ', &
            e12.5, ' kV  particles left  ', f7.0)
          write (12, *)
        end if
        ! QUAFK  quadrupole(magnetic or electric)
        if (iitem(i)==19) then
          ! electric quadrupole
          if (ityq) then
            write (12, 2110) dav1(i, 4), dav1(i, 1), dav1(i, 7), dav1(i, 2), dav1(i, 6), dav1(i, 5), dav1(i, 3), &
              dav1(i, 36)
2110        format (f9.2, ' mm  Quadrupole (electric): length = ', e12.5, ' mm   aperture radius = ', e12.5, ' mm', /, &
              ' voltage = ', e12.5, ' kV   K2 = ', e12.5, ' cm-2  gradient = ', e12.5, ' kV/cm2', /, ' rigidity = ', &
              e12.5, ' kV   particles left  ', f7.0)
          else
            ! magnetic quadrupole
            write (12, 2111) dav1(i, 4), dav1(i, 1), dav1(i, 7), dav1(i, 2), dav1(i, 6), dav1(i, 5), dav1(i, 3), &
              dav1(i, 36)
2111        format (f9.2, ' mm  Quadrupole (magnetic): length = ', e12.5, ' mm  aperture radius= ', e12.5, ' mm', /, &
              ' field = ', e12.5, ' kG   K2 = ', e12.5, ' cm-2  gradient = ', e12.5, ' kG/cm', /, ' momentum = ', e12.5, &
              ' kG.cm   particles left  ', f7.0)
          end if
          write (12, *)
        end if
        if (iitem(i)==20) then
          ! rotating the transverse coordinates about the z axis
          write (12, 2112) dav1(i, 1)
2112      format (9x, 'rotating the transverse coordinates', ' about the z-axis by an angle: ', e12.5, ' deg')
          write (12, *)
        end if
        ! EDFLEC electric deflector
        if (iitem(i)==21) then
          write (12, 3010) dav1(i, 4), dav1(i, 1), dav1(i, 2), dav1(i, 3), dav1(i, 5), dav1(i, 6), dav1(i, 7), &
            dav1(i, 8), dav1(i, 36)
3010      format (f9.2, ' mm  Deflector (electric): length = ', e12.5, ' mm bend angle = ', e12.5, ' deg', /, &
            '  bend radius = ', e12.5, ' mm  radii = ', e12.5, '  field index = ', e12.5, /, '  rigidity = ', e12.5, &
            ' kV field = ', e12.5, ' kV/mm', '  particles left  ', f7.0)
          write (12, *)
        end if
        ! end (big boucle)
      end do
      return
    end subroutine daves
    ! *******************************************************************
    ! SUBROUTINE POFAR1(GAP)
    ! ENTRANCE OR EXIT OF THE BENDING MAGNET,
    ! MATRIX R AND T ARE IN (M,RD)
    ! **** WARNING : IN THIS ROUTINE ALL VARIABLES ARE REAL UNLESS
    ! OTHERWIZE DECLARED *********
    ! *******************************************************************
    subroutine pofar1(gap)
      implicit real *8(a-z)
      ! -- POLE FACE ROTATION
      common /bloc21/be, apb(2), layl, layx, rabt
      common /bloc23/h, devi, nb, bdb, l
      common /bloc11/r(6, 6), t(6, 6, 6)
      common /secdr/iseor
      logical iseor
      ! H      : INVERSE OF THE MAGNET RADIUS (1./CM)
      ! NB     : DIMENSIONLESS TRANSPORT n coefficient
      ! BDB    : TRANSPORT beta coefficient
      ! APB( ) : HALF GAP (CM)
      ! L      : LENGTH OF THE MAGNET (CM)
      ! BE     : ANGLE OF INLINATION (RAD)
      ! LAYL   : K1 TRANSPORT COEFFICIENT
      ! LAYX   : K2 TRANSPORT COEFFICIENT
      ! RABT   : INVERSE OF THE RADIUS OF CURVATURE (1/CM)

      ! SAVE H, GAP AND RABT BEFORE CONVERSION IN M UNITS
      sah = h
      sarabt = rabt
      sagap = gap
      h = h*100.
      gap = gap*1.e-02
      rabt = rabt*100.
      tb = tan(be)
      cb = cos(be)
      sb = (1.0+sin(be)**2)/cb
      tcor = 2.0*h*gap*layl
      be1 = be - tcor*sb*(1.-layx*tcor*tb)
      tb1 = tan(be1)
      tb2 = tb**2
      r(2, 1) = h*tb
      r(4, 3) = -h*tb1
      if (.not. iseor) go to 3333
      sb = 1./cb
      sb2 = sb**2
      sb3 = sb2*sb
      t(1, 1, 1) = -0.5*h*tb2
      t(1, 3, 3) = 0.5*h*sb2
      t(2, 1, 1) = 0.5*h*rabt*sb3 - tb*nb*h**2
      t(2, 1, 2) = h*tb2
      t(2, 1, 6) = -h*tb
      t(2, 3, 3) = h**2*(nb+0.5+tb2)*tb - 0.5*h*rabt*sb3
      t(2, 3, 4) = -h*tb2
      t(3, 1, 3) = h*tb2
      t(4, 1, 3) = -h*rabt*sb3 + 2.*h**2*nb*tb
      t(4, 1, 4) = -h*tb2
      t(4, 2, 3) = -h*sb2
      sec2 = cos(be1)*cos(be1)
      sec2 = 1./sec2
      t(4, 3, 6) = h*tb - h*tcor*sec2
3333  continue
      ! RESTORE H , RABT, APB(2)
      h = sah
      rabt = sarabt
      gap = sagap
      return
    end subroutine pofar1
    ! *******************************************************************
    ! SUBROUTINE POFAR2(GAP)
    ! FIRST AND SECOND order MATRIX R AND T
    ! SAVE H, GAP AND RABT BEFORE CONVERSION IN M UNITY
    ! **** WARNING : IN THIS ROUTINE ALL VARIABLES ARE REAL UNLESS
    ! OTHERWIZE DECLARED *********
    ! *******************************************************************
    subroutine pofar2(gap)
      implicit real *8(a-z)
      ! -- POLE FACE ROTATION
      common /bloc21/be, apb(2), layl, layx, rabt
      common /bloc23/h, devi, nb, bdb, l
      common /bloc11/r(6, 6), t(6, 6, 6)
      common /secdr/iseor
      logical iseor
      ! H      : INVERSE OF THE MAGNET RADIUS (1./CM)
      ! NB     : DIMENSIONLESS TRANSPORT n coefficient
      ! BDB    : TRANSPORT beta coefficient
      ! APB( ) : HALF GAP (CM)
      ! L      : LENGTH OF THE MAGNET (CM)
      ! BE     : ANGLE OF INLINATION (RAD)
      ! LAYL   : K1 TRANSPORT COEFFICIENT
      ! LAYX   : K2 TRANSPORT COEFFICIENT
      ! RABT   : INVERSE OF THE RADIUS OF CURVATURE (1/CM)

      sah = h
      sarabt = rabt
      sagap = gap
      h = h*100.
      gap = gap*1.e-02
      rabt = rabt*100.
      tb = tan(be)
      cb = cos(be)
      sb = (1.0+sin(be)**2)/cb
      tcor = 2.0*h*gap*layl
      be1 = be - tcor*sb*(1.-layx*tcor*tb)
      tb1 = tan(be1)
      tb2 = tb**2
      r(2, 1) = h*tb
      r(4, 3) = -h*tb1
      if (.not. iseor) go to 4444
      sb = 1./cb
      sb2 = sb**2
      sb3 = sb2*sb
      t(1, 1, 1) = 0.5*h*tb2
      t(1, 3, 3) = -0.5*h*sb2
      t(2, 1, 1) = 0.5*h*rabt*sb3 - tb*(nb+0.5*tb2)*h**2
      t(2, 1, 2) = -h*tb2
      t(2, 1, 6) = -h*tb
      t(2, 3, 3) = h**2*(nb-0.5*tb2)*tb - 0.5*h*rabt*sb3
      t(2, 3, 4) = h*tb2
      t(3, 1, 3) = -h*tb2
      t(4, 1, 3) = -h*rabt*sb3 + h**2*(2.*nb+sb2)*tb
      t(4, 1, 4) = h*tb2
      t(4, 2, 3) = h*sb2
      sec2 = cos(be1)*cos(be1)
      sec2 = 1./sec2
      t(4, 3, 6) = h*tb - h*tcor*sec2
4444  continue
      ! RESTORE H , RABT, APB(2)
      h = sah
      rabt = sarabt
      gap = sagap
      return
    end subroutine pofar2
    ! *******************************************************************
    ! SUBROUTINE BENMAG(sbet,fdtot)
    ! IDEAL MAGNET, MATRIX R AND T ARE IN (M,RD)
    ! **** WARNING : IN THIS ROUTINE ALL VARIABLES ARE REAL UNLESS
    ! OTHERWIZE DECLARED *********
    ! *******************************************************************
    subroutine benmag(sbet, fdtot)
      implicit real *8(a-z)
      ! -- POLE FACE ROTATION
      common /bloc21/be, apb(2), layl, layx, rabt
      common /bloc23/h, devi, nb, bdb, l
      common /bloc11/r(6, 6), t(6, 6, 6)
      common /secdr/iseor
      logical iseor
      ! H      : INVERSE OF THE MAGNET RADIUS (1./CM)
      ! NB     : DIMENSIONLESS TRANSPORT n coefficient
      ! BDB    : TRANSPORT beta coefficient
      ! APB( ) : HALF GAP (CM)
      ! L      : LENGTH OF THE MAGNET (CM)
      ! BE     : ANGLE OF INLINATION (RAD)
      ! LAYL   : K1 TRANSPORT COEFFICIENT
      ! LAYX   : K2 TRANSPORT COEFFICIENT
      ! RABT   : INVERSE OF THE RADIUS OF CURVATURE (1/CM)

      ! sbet is relativistic beta of the charge state of interest
      sgam2 = 1./(1.-sbet*sbet)
      ! SAVE H BEFORE CONVERSION IN m
      sah = h
      h = h*100.
      fieldn = nb
      beta = bdb
      al = l*1.e-02
      rad = 1.0/h
      h2 = h*h
      h3 = h2*h
      h4 = h3*h
      h5 = h4*h
      h6 = h5*h
      kx2 = (1.0-fieldn)*h2
      ky2 = fieldn*h2
      kx = sqrt(abs(kx2))
      ky = sqrt(abs(ky2))
      kx3 = kx2*kx
      argx = kx*al
      argy = ky*al
      sinx = sin(argx)
      shx = sinh(argx)
      al2 = al*al
      al3 = al2*al
      cx = 0.
      sx = 0.
      dx = 0.
      j1xl = 0.
      if (kx2<6.*0) then
        cx = cosh(argx)
        sx = sinh(argx)/kx
        dx = h*(1.0-cx)/kx2
        j1xl = (argx-shx)/kx3
      end if
      if (kx2==6.*0) then
        cx = 1
        sx = al
        dx = h*al2/2.0
        j1xl = al3/6.0
      end if
      if (kx2>6.*0) then
        cx = cos(argx)
        sx = sin(argx)/kx
        dx = h*(1.0-cx)/kx2
        j1xl = (argx-sinx)/kx3
      end if
      cpx = -kx2*sx
      spx = cx
      dpx = h*sx
      cy = 0.
      sy = 0.
      if (ky2<6.*0) then
        cy = cosh(argy)
        sy = sinh(argy)/ky
      end if
      if (ky2==6.*0) then
        cy = 1.0
        sy = al
      end if
      if (ky2>6.*0) then
        cy = cos(argy)
        sy = sin(argy)/ky
      end if
      cpy = -ky2*sy
      spy = cy
      ! First order Matrix R
      r(1, 1) = cx
      r(1, 2) = sx
      r(1, 6) = dx
      r(2, 1) = cpx
      r(2, 2) = spx
      r(2, 6) = dpx
      r(3, 3) = cy
      r(3, 4) = sy
      r(4, 3) = cpy
      r(4, 4) = spy
      r(5, 1) = h*sx
      r(5, 2) = dx
      r(5, 6) = h2*j1xl
      ! Carey eq.2.41 p 34
      r(5, 6) = r(5, 6) - al*fdtot/sgam2
      ! ************************
      if (.not. iseor) go to 3334
      ! Second order Matrix T
      cosx = cos(argx)
      chx = cosh(argx)
      kx4 = kx2*kx2
      kx6 = kx4*kx2
      argy = ky*al
      siny = sin(argy)
      cosy = cos(argy)
      shy = sinh(argy)
      chy = cosh(argy)
      ky3 = ky2*ky
      ky4 = ky2*ky2
      targx = argx + argx
      sin2x = sin(targx)
      cos2x = cos(targx)
      sh2x = sinh(targx)
      ch2x = cosh(targx)
      kx3 = kx*kx2
      kx5 = kx3*kx2
      kx7 = kx5*kx2
      targy = argy + argy
      sin2y = sin(targy)
      cos2y = cos(targy)
      sh2y = sinh(targy)
      ch2y = cosh(targy)
      al4 = al3*al
      al5 = al4*al
      al6 = al5*al
      al7 = al6*al
      c = 1.0/(kx2-4.0*ky2)
      j1l = 0.
      j2l = 0.
      j3l = 0.
      j2xl = 0.
      j3xl = 0.
      j4xl = 0.
      j5xl = 0.
      j7xl = 0.
      j9xl = 0.
      j10xl = 0.
      j11xl = 0.
      j12xl = 0.
      j13xl = 0.
      j14xl = 0.
      j15xl = 0.
      j16xl = 0.
      j17xl = 0.
      if (kx2>6.*0) then
        cx = dcos(kx*al)
        sx = dsin(kx*al)/kx
        dx = h*(1.0d0-cx)/kx2
        j1xl = (argx-sinx)/kx3
        j2xl = (1.0-cosx-.5*argx*sinx)/kx4
        j3xl = .5*(sinx-argx*cosx)/kx3
        j4xl = (.5*argx-2.0*sinx/3.0+sin2x/12.)/kx5
        j5xl = (.25d0-cosx/3.0+cos2x/12.0)/kx4
        j10xl = (argx-1.5*sinx+.5*argx*cosx)/kx5
        j11xl = (-2.0*argx+3.0*sinx-argx*cosx)/kx5
        j12xl = (4.0*argx-5.5*sinx+1.5*argx*cosx)/kx3
        j13xl = (.75-2.0*cosx/3.0-cos2x/12.0-.5*argx*sinx)/kx6
        j14xl = (1.5-4.0*cosx/3.0-cos2x/6.0-argx*sinx)/kx6
        j15xl = (-1.75+4.0*cosx/3.0+5.0*cos2x/12.0+1.5*argx*sinx)/kx4
        j16xl = (1.5*argx-7.0*sinx/3.0-sin2x/12.0+argx*cosx)/kx7
        j17xl = (-1.75*argx+17.0*sinx/6.0+5.0*sin2x/24.0-1.5*argx*cosx)/kx5
        j1l = (.5*argx-.25*sin2x)/kx3
        j2l = (.5*argx+.25*sin2x)/kx
        j3l = .25*(1.0-cos2x)/kx2
        if (ky2<6.*0) then
          j7xl = .5*(argx-sinx+kx2*c*(sinx-.5*kx*sh2y/ky))/(kx3*ky2)
          j9xl = c*((cosx-1.0)/kx2+(1.0-ch2y)/(4.0*ky2))
        end if
        if (ky2==6.*0) then
          j7xl = (2.0*(sinx-argx)/kx3+al3/3.0)/kx2
          j9xl = al2/(2.0*kx2) + (cosx-1.0)/kx4
        end if
        if (ky2>6.*0) then
          j7xl = .5*(argx-sinx+kx2*c*(sinx-.5*kx*sin2y/ky))/(kx3*ky2)
          j9xl = c*((cosx-1.0)/kx2+(1.0-cos2y)/(4.0*ky2))
        end if
        ! endif kx2.gt.0.
      end if
      if (kx2<6.*0) then
        cx = cosh(kx*al)
        sx = sinh(kx*al)/kx
        dx = h*(1.0-cx)/kx2
        j1xl = (argx-shx)/kx3
        j2xl = (1.0-chx+.5*argx*shx)/kx4
        j3xl = .5*(shx-argx*chx)/kx3
        j4xl = (.5*argx-2.0*shx/3.0+sh2x/12.0)/kx5
        j5xl = (.25-chx/3.0+ch2x/12.0)/kx4
        j10xl = (argx-1.5*shx+.5*argx*chx)/kx5
        j11xl = (-2.0*argx+3.0*shx-argx*chx)/kx5
        j12xl = (4.0*argx-5.5*shx+1.5*argx*chx)/kx3
        j13xl = (.75-2.0*chx/3.0-ch2x/12.0+.5*argx*shx)/kx6
        j14xl = (1.5-4.0*chx/3.0-ch2x/6.0+argx*shx)/kx6
        j15xl = (-1.75+4.0*chx/3.0+5.0*ch2x/12.0-1.5*argx*shx)/kx4
        j16xl = (1.5*argx-7.0*shx/3.0-sh2x/12.0+argx*chx)/kx7
        j17xl = (-1.75*argx+17.0*shx/6.0+5.0*sh2x/24.0-1.5*argx*chx)/kx5
        j1l = (.5*argx-.25*sh2x)/kx3
        j2l = (.5*argx+.25*sh2x)/kx
        j3l = .25*(1.0-ch2x)/kx2
        if (ky2<6.*0) then
          j7xl = .5*(argx-shx+kx2*c*(shx-.5*kx*sh2y/ky))/(kx3*ky2)
          j9xl = c*((chx-1)/kx2+(1.0d0-ch2y)/(4.0d0*ky2))
        end if
        if (ky2==6.*0) then
          j7xl = (2.0*(sinx-argx)/kx3+al3/3.0d0)/kx2
          j9xl = al2/(2.0d0*kx2) + (chx-1.0d0)/kx4
        end if
        if (ky2>6.*0) then
          j7xl = .5*(argx-shx+kx2*c*(shx-.5d0*kx*sin2y/ky))/(kx3*ky2)
          j9xl = c*((chx-1.0)/kx2+(1.0-cos2y)/(4.0*ky2))
        end if
        ! end kx2.lt.0.
      end if
      if (kx2==6.*0) then
        cx = 1
        sx = al
        dx = h*al*al/2.0
        j1xl = al3/6.0
        j2xl = al4/24.0
        j3xl = al3/6.0
        j4xl = al5/60.0
        j5xl = al4/24.0
        j7xl = (al3/12.0-al/(8.0*ky2)-sin2y/(16.0*ky3))/ky2
        j10xl = -al5/24.0
        j11xl = -al5/60.0
        j12xl = al3/6.0
        j9xl = al2/(8.0*ky2) - (1.0-cos2y)/(16.0*ky4)
        j13xl = al6/240.0
        j14xl = al6/1080.0
        j15xl = al4/12.0
        j16xl = al7/840.0
        j17xl = al5/60.0
        j1l = al3/3.0
        j2l = al
        j3l = al2/2.0
        ! end kx2.eq.0.
      end if
      cpx = -kx2*sx
      spx = cx
      dpx = h*sx
      j4l = 0.
      j5l = 0.
      j6l = 0.
      if (ky2<6.*0) then
        cy = cosh(ky*al)
        sy = sinh(ky*al)/ky
        j4l = (.5*argy-.25*sh2y)/ky3
        j5l = (.5*argy+.25*sh2y)/ky
        j6l = .25*(1.0-ch2y)/ky2
      end if
      if (ky2==6.*0) then
        cy = 1.0
        sy = al
        j4l = al3/3.0
        j5l = al
        j6l = al2/2.0
      end if
      if (ky2>6.*0) then
        cy = cos(ky*al)
        sy = sin(ky*al)/ky
        j4l = (.5*argy-.25*sin2y)/ky3
        j5l = (.5*argy+.25*sin2y)/ky
        j6l = .25*(1.0-cos2y)/ky2
      end if
      cpy = -ky2*sy
      spy = cy
      sy2 = sy*sy
      a = 2.0*fieldn - 1.0 - beta
      b = (2.0-fieldn)
      bn1 = 2.0*fieldn - 1.0 - beta
      bn2 = 2.5*fieldn - beta - 1.5
      bn3 = 2.0*beta - fieldn
      ! tabulation of the integrals (notations TRANSPORT SLAC R-75 table VIb)
      i10 = dx/h
      i11 = 0.5*al*sx
      i111 = 1.0*(sx**2+dx*rad)/3.0
      i112 = sx*dx*rad/3.0
      i133 = dx/h - (ky2/(kx2-4.0*ky2))*(sy2-2.0*dx*rad)
      i134 = c*(sy*cy-sx)
      i144 = (sy2-2.0*dx*rad)*c
      i20 = sx
      i21 = (sx+al*cx)/2.0
      i22 = i11
      i211 = sx*(1.0+2.0*cx)/3.0
      i212 = (2.0*sx**2-dx/h)/3.0
      i222 = 2.0*sx*dx*rad/3.0
      i233 = sx - 2.0*ky2*(sy*cy-sx)*c
      i234 = (kx2*dx*rad-2.0*ky2*sy2)*c
      i244 = 2.0*c*(sy*cy-sx)
      i33 = 0.5*al*sy
      if (ky2==6.*0) i34 = al3/6.0
      if (ky2/=6.*0) i34 = 0.5*(sy-al*cy)/ky2
      i314 = (2.0*sx*cy-sy*(1.0+cx))*c
      i324 = c*(2.0*cy*dx*rad-sx*sy)
      i43 = 0.5*(sy+al*cy)
      i44 = i33
      i413 = c*((kx2-2.0*ky2)*sx*cy-ky2*sy*(1.0+cx))
      i414 = c*((kx2-2.0*ky2)*sx*sy-cy*(1.0-cx))
      i424 = c*(cy*sx-cx*sy-2.0*ky2*sy*dx*rad)
      i12 = (sx-al*cx)*0.5/kx2
      i27 = (dx*rad-.5*al*sx)/kx2
      i313 = c*(kx2*cy*dx*rad-2.0*sx*sy*ky2)
      i314 = (2.0*sx*cy-sy*(1.0+cx))*c
      i324 = c*(2.0*cy*dx*rad-sx*sy)
      i43 = 0.5*(sy+al*cy)
      i44 = i33
      i413 = c*((kx2-2.0*ky2)*sx*cy-ky2*sy*(1.0+cx))
      i414 = c*((kx2-2.0*ky2)*sx*sy-cy*(1.0-cx))
      i424 = c*(cy*sx-cx*sy-2.0*ky2*sy*dx*rad)
      if (kx/=6.*0) then
        i12 = (sx-al*cx)*0.5/kx2
        i27 = (dx*rad-.5*al*sx)/kx2
        i116 = (0.5*al*sx-(sx**2+dx/h)/3.0)*h/kx2
        i122 = (2.0*dx/h-sx**2)/3.0/kx2
        i126 = h*(sx+2.0*sx*cx-3.0*al*cx)/6.0/kx2**2
        i166 = h2*(4.0*dx*rad/3.0+sx**2/3.0-al*sx)/kx2**2
        i216 = h*(al*cx/2.0+sx/6.0-2.0*sx*cx/3.0)/kx2
        i226 = h*(0.5*al*sx-2.0*sx**2/3.0+dx*rad/3.0)/kx2
        i266 = h2*(sx/3.0+2.0*sx*cx/3.0-al*cx)/kx2**2
        i323 = c*(2.0*ky2*sy*(1.0+cx)/kx2-sx*cy) + sy/kx2
        i336 = h*(0.5*al*sy-c*(cy*(1.0-cx)-2.0*ky2*sx*sy))/kx2
        i346 = h*(i34-c*(2.0*sx*cy-sy*(1.0+cx)))/kx2
        i423 = c*(2.0*ky2*cy*(1.0+cx)/kx2-cx*cy-ky2*sx*sy) + cy/kx2
        i436 = h*(0.5*al*cy+0.5*sy+c*(ky2*sy*(1.0+cx)-(kx2-2.0*ky2)*sx*cy))/kx2
        i446 = h*(al*sy*0.5-c*((kx2-2.0*ky2)*sx*sy-cy*(1.0-cx)))/kx2
        i26 = i12*h
      else
        i12 = al3/6.0
        i27 = al4/12.0
        i116 = h*al4/24.0
        i122 = al4/12.0
        i126 = h*al5/40.0
        i166 = h2*al2/120.0
        i216 = h*al3/6.0
        i226 = h*al4/8.0
        i266 = h2*al5/20.0
        i323 = al2*sy/4.0
        i336 = h*al*(al2*sy/12.0+(al*cy-sy)/(ky2*8.0))
        i346 = h*al2*(sy/(ky2*8.0)-al*cy/(ky2*12.0))
        i423 = (al2*cy+al*sy)/4.0
        i436 = h*al2*(sy/8.0+cy*al/12.0)
        i446 = h*al*(al2*sy/12.0+(sy-al*cy)/(ky2*8.0))
        i26 = i12*h
      end if
      ! MATRIX T(i,j,k), TRANSPORT SLAC R-75 table VIa

      t(1, 1, 1) = a*h3*i111 + 0.5*kx2**2*i122*h
      t(1, 1, 2) = 2.0*a*h3*i112 - kx2*h*i112 + h*sx
      t(1, 1, 6) = b*h2*i11 + 2.0*a*h3*i116 - kx2*h2*i122
      t(1, 2, 2) = a*h3*i122 + 0.5*h*i111
      t(1, 2, 6) = b*h2*i12 + 2.0*a*h3*i126 + h2*i112
      t(1, 3, 3) = beta*h3*i133 - 0.5*ky2*h*i10
      t(1, 3, 4) = 2.0*beta*h3*i134
      t(1, 4, 4) = beta*h3*i144 - 0.5*h*i10
      t(1, 6, 6) = b*h2*h*i27 + a*h3*i166 + 0.5d0*h3*i122 - h*i10

      t(2, 1, 1) = a*h3*i211 + 0.5*kx2**2*h*i222 - h*cx*cpx
      t(2, 1, 2) = h*spx + 2.0d0*a*h3*i212 - kx2*h*i212 - h*(cx*spx+cpx*sx)
      t(2, 1, 6) = b*h2*i21 + 2.0*a*h3*i216 - kx2*h2*i222 - h*(cx*dpx+cpx*dx)
      t(2, 2, 2) = a*h3*i222 + 0.5*h*i211 - h*sx*spx
      t(2, 2, 6) = b*h2*i22 + 2.0*a*h3*i226 + h2*i212 - h*(sx*dpx+spx*dx)
      t(2, 3, 3) = beta*h3*i233 - 0.5*ky2*h*i20
      t(2, 3, 4) = 2.0*beta*h3*i234
      t(2, 4, 4) = beta*h3*i244 - 0.5*h*i20
      t(2, 6, 6) = b*h2*i26 + a*h3*i266 + 0.5*h3*i222 - h*dx*dpx - h*i20

      ! VALUE OF "B" IS CHANGED.

      b = beta - fieldn

      t(3, 1, 3) = 2.0*b*h3*i313 + kx2*ky2*h*i324
      t(3, 1, 4) = h*sy + 2.0d0*b*h3*i314 - kx2*h*i323
      t(3, 2, 3) = 2.0*b*h3*i323 - ky2*h*i314
      t(3, 2, 4) = 2.0*b*h3*i324 + h*i313
      t(3, 3, 6) = ky2*i33 + 2.0*b*h3*i336 - ky2*h2*i324
      t(3, 4, 6) = ky2*i34 + 2.0*b*h3*i346 + h2*i323

      t(4, 1, 3) = 2.0*b*h3*i413 + kx2*ky2*h*i424 - h*cx*cpy
      t(4, 1, 4) = h*spy + 2.0*h3*b*i414 - kx2*h*i423 - h*cx*spy
      t(4, 2, 3) = 2.0*b*h3*i423 - ky2*h*i414 - h*sx*cpy
      t(4, 2, 4) = 2.0*b*h3*i424 + h*i413 - h*sx*spy
      t(4, 3, 6) = ky2*i43 + 2.0*b*h3*i436 - ky2*h2*i424 - h*dx*cpy
      t(4, 4, 6) = ky2*i44 + 2.0*b*h3*i446 + h2*i423 - h*dx*spy

      t(5, 1, 1) = h4*(bn1*j1xl-bn2*kx2*j4xl) + .5*kx4*j1l
      t(5, 1, 2) = h4*2.0*bn2*j5xl - kx2*j3l + h*dx
      t(5, 1, 6) = h5*j11xl + h3*j12xl + h*kx2*j3xl + h5*2.0*bn2*j4xl + 2.0*beta*h5*j10xl - h*kx2*j1l
      ! Carey eq. 7.45  p.143
      t(5, 1, 6) = t(5, 1, 6) - r(5, 1)/sgam2

      t(5, 2, 2) = .5*(h2*j1xl+h4*2.0*bn2*j4xl+j2l)
      t(5, 2, 6) = -2.0*beta*h5*j13xl + h5*j14xl + h3*j15xl + h*kx2*j2xl + h*j3l
      ! Carey eq. 7.45  p.143
      t(5, 2, 6) = t(5, 2, 6) - r(5, 2)/sgam2

      t(5, 3, 3) = .5*(h4*(bn3*j1xl-2.0*beta*ky2*j7xl)+ky4*j4l)
      t(5, 3, 4) = 2.0*beta*h4*j9xl - ky2*j6l
      t(5, 4, 4) = beta*h4*j7xl - .5*(h2*j1xl-j5l)
      t(5, 6, 6) = (1.0-beta)*h6*j16xl + h4*j17xl - h2*j3xl + .5*h2*j1l
      ! Carey eq. 7.45  p.143
      t(5, 6, 6) = t(5, 6, 6) - r(5, 6)/sgam2
      t(5, 6, 6) = t(5, 6, 6) + al*((1./sgam2)**2+1.5*sbet*sbet/sgam2)
      ! Carey eq.7.46 p.143
      t(5, 5, 6) = -1./sgam2
3334  continue
      ! RESTORE H
      h = sah
      return
    end subroutine benmag
    ! *******************************************************************
    ! SUBROUTINE syrout(ii)
    ! SYNCHROTRON RADIATION EXCITATION FOR PARTICLE ii
    ! The method is described in 'synchrotron radiation in DYNAC'
    ! *******************************************************************
    subroutine syrout(ii)
      implicit real *8(a-h, o-z)
      parameter(iptsz=100002, maxcell=3000, maxcell1=3000)
      common /consta/vl, pi, xmat, rpel, qst
      common /faisc/f(10, iptsz), imax, ngood
      common /bloc11/r(6, 6), t(6, 6, 6)
      common /radia/trt, rmoy, xintf, crae
      ! *************************************************************************************
      ! Synchrotron radiation
      ! COMMON/RADIA/TRT,RMOY,XINTF,CRAE
      ! TRT   : t.o.f in sec for a particle crossing the bending magnet
      ! RMOY  : average radius of the bending magnet in the magnetic plane
      ! XINTF : integral of (u/uc) * S(u/uc) where S(u/uc) is the spectral function
      ! ( see Synchrotron radiation in DYNAC)
      ! CRAE    : classical electron radius (cm)
      ! ***************************************************************************************
      ! PGAM  : Instantaneous radiation power (MeV/sec)
      ! ETA   : eta=u/uc
      ! uc    :  critical quanta energy (eV)
      ! u     :  quanta energy (eV) considered
      ! the most significant quanta are assumed emitted between: 0.1<eta<3.
      e4ii = f(7, ii)**4
      gpaii = f(7, ii)/xmat
      cgam = (4.*pi/3.)*crae/(xmat**3)
      pgam = vl*cgam*e4ii/(2.*pi*rmoy*rmoy)
      ! ELOST  : Total energy lost due to radiation (MeV)
      elost = xintf*pgam*trt
      ! variation of the momentum (only available for relativistic electrons)
      dmo = -elost/f(7, ii)
      ! change the total energy (MeV)
      f(7, ii) = f(7, ii) - elost
      ! change f(2,ii) and f(3,ii)
      ! dmo*r(1,6) is given in m and  dmo*r(2,6) in rad, convert in cm and mrad
      f(2, ii) = f(2, ii) + dmo*r(1, 6)*100.
      f(3, ii) = f(3, ii) + dmo*r(2, 6)*1000.
      return
    end subroutine syrout
    ! *******************************************************************
    ! SUBROUTINE syref
    ! SYNCHROTRON RADIATION EXCITATION FROM PARTICLE REFERENCE
    ! The method is described in 'synchrotron radiation in DYNAC'
    ! *******************************************************************
    subroutine syref
      implicit real *8(a-h, o-z)
      parameter(iptsz=100002, maxcell=3000, maxcell1=3000)
      common /consta/vl, pi, xmat, rpel, qst
      common /radia/trt, rmoy, xintf, crae
      common /dyn/tref, vref
      common /bloc23/h, devi, nb, bdb, l
      common /itvole/itvol, imamin
      common /tofev/ttvols
      logical itvol, imamin
      real *8 l, nb

      beref = vref/vl
      gamref = 1./sqrt(1.-beref*beref)
      ener = xmat*gamref*beref
      trt = l/vref
      e4 = ener**4
      cgam = (4.*pi/3.)*crae/(xmat**3)
      pgam = vl*cgam*e4/(2.*pi*rmoy*rmoy)
      ! ELOST  : Total energy lost due to radiation (MeV)
      ! change vref and tref of the reference
      elost = xintf*pgam*trt
      fener = ener - elost
      fgam = fener/xmat
      fberef = sqrt(1.-1./(fgam*fgam))
      vref = fberef*vl
      tref = tref + l/vref
      if (itvol) ttvols = tref
      write (16, 250) elost, ener, fener
250   format (//, ' REFERENCE AFTER RADIATION EXITATION*****', /, '    ENERGY LOST (MeV):  ', e12.5, /, &
        '    OLD ENERGY  (MeV):  ', e12.5, /, '    NEW ENERGY  (MeV):  ', e12.5)
      return
    end subroutine syref
    ! *******************************************************************
    ! SUBROUTINE sextu(imk2,arg,xlsex,rg)
    ! magnetic sextupole
    ! space charge at the middle of the lens
    ! *******************************************************************
    subroutine sextu(imk2, arg, xlsex, rg)
      implicit real *8(a-h, o-z)
      parameter(iptsz=100002, maxcell=3000, maxcell1=3000)
      common /fene/wdisp, wphas, wx, wy, rlim, ifw
      common /ttfc/tk, t1k, t2k, sk, s1k, s2k, fh
      common /dyn/tref, vref
      common /consta/vl, pi, xmat, rpel, qst
      common /rigid/boro
      common /faisc/f(10, iptsz), imax, ngood
      common /etcom/cog(8), exten(17), fd(iptsz)
      common /qmoyen/qmoy
      common /dcspa/iesp
      logical iesp
      common /sc3/beamc, scdist, sce10, cplm, ect, apl, ichaes, iscsp
      logical ichaes
      common /tapes/in, ifile, meta
      common /pltprf/sprfx(3000), sprfy(3000), sprfl(3000), sprfw(3000), sprfp(3000), sprng(3000), iprf
      common /davcom/dav1(maxcell1, 40), davtot, iitem(maxcell1), idav
      common /shif/dtiph, shift
      logical shift
      common /compt/nrres, nrtre, nrbunc, nrdbun
      common /rander/ialin
      logical ialin
      common /qskew/qtwist, iqrand, itwist, iaqu
      logical itwist
      common /femt/iemgrw, iemqesg
      logical iemgrw
      common /cgtof/charm(20), cgtdv(20), nbch(20), netac
      common /qsex/l, kq2, ks2
      real *8 l, kq2, ks2
      character *1 cr
      dimension trans(2)

      ilost = 0
      write (16, *) ' ******SEXTUPOLE*********'
      ! statistics
      if (iprf==1) call stapl(davtot*10.)
      nrtre = nrtre + 1
      cr = char(13)
      ! print out on terminal of transport element # on one and the same line
      write (6, 8254) nrtre, nrres, cr
8254  format ('Transport element:', i5, '      Accelerating element:', i5, a1, $)
      len = 1
      ! if itwist=.true. skews the sextupole before misalignments
      sqtwist = 0.
      if (itwist .and. arg/=0.) then
        if (iqrand==0) then
          qtwrad = qtwist
          sqtwist = qtwrad
          call zrotat(qtwrad)
        else
          rdcf = .5
          call rlux(trans, len)
          if (trans(1)<=rdcf) sign = -1.
          if (trans(1)>rdcf) sign = 1.
          call rlux(trans, len)
          qtwrad = qtwist*sign*trans(1)
          sqtwist = qtwrad
          call zrotat(qtwrad)
        end if
      end if
      if (ialin) call randali
      fh0 = fh/vl
      write (16, *) 'TOF at input:', tref*fh*180./pi, ' deg'

      gpa = 0.
      do ii = 1, ngood
        gpa = gpa + f(7, ii)/xmat
      end do
      gpa = gpa/float(ngood)
      l = xlsex
      bpa = sqrt(1.-1./(gpa*gpa))
      xmco = xmat*bpa*gpa
      ri = 33.356*xmco*1.e-01/qst
      if (imk2/=0) then
        ! arg: field B (kG)
        fb = arg
        b = arg/(rg*rg)
        ks2 = b/ri
      else
        ! arg: KS2 (cm-3)
        ks2 = arg
        b = ks2*ri
        fb = b*(rg*rg)
      end if
      write (16, 3300) xlsex, rg, fb, ks2, b, ri
3300  format (' LENGTH = ', e12.3, ' cm  APERTURE RADIUS= ', e12.5, ' cm', /, ' FIELD = ', e12.5, ' kG  KS2 = ', e12.5, &
        ' cm-3', '  GRADIENT = ', e12.5, ' kG/(cm*cm)', /, ' MOMENTUM = ', e12.5, ' kG.cm', /)
      call clear
      call elsex
      ! print transport matrix (c.o.g.)
      call matrix
      ! start daves
      idav = idav + 1
      iitem(idav) = 10
      dav1(idav, 1) = xlsex*10.
      dav1(idav, 2) = b
      dav1(idav, 3) = fb
      davtot = davtot + xlsex
      dav1(idav, 4) = davtot*10.
      dav1(idav, 5) = ks2
      dav1(idav, 6) = rg
      dav1(idav, 7) = ri
      ! first half sextupole
      l = xlsex/2.
      do ii = 1, ngood
        call clear
        gpai = f(7, ii)/xmat
        bpai = sqrt(1.-1./(gpai*gpai))
        xmco = xmat*bpai*gpai
        ri = 33.356*xmco*1.e-01/f(9, ii)
        ks2 = b/ri
        call elsex
        call cobeam(ii, l)
        ! the evolution of the t.o.f is made in routine cobeam)
        ! omment      f(6,ii)=f(6,ii)+l/(bpai*vl)
      end do
      ! Charge space effect (if dl >0)
      if (ichaes .and. l>0.) then
        if (sce10==1 .or. sce10==3.) then
          iesp = .true.
          write (16, *) 'space charge at the middle  '
          call cesp(xlsex)
          iesp = .false.
        end if
      end if
      bcour = 0.
      do i = 1, ngood
        gpai = f(7, i)/xmat
        bcour = sqrt(1.-1./(gpai*gpai)) + bcour
      end do
      bcour = bcour/float(ngood)
      gcour = 1./sqrt(1.-bcour*bcour)
      wcg = (gcour-1.)*xmat
      ! ----- convert wdisp in dp/p (window control)
      ! ---- ifw = 0 ===> wdisp = dW/W
      ! ---- ifw = 1 ===> wdisp = dW (MeV)
      if (ifw==0) dispr = gcour*gcour*wdisp/(gcour*(gcour+1.))
      if (ifw==1) dispr = gcour*gcour*wdisp/(gcour*(gcour+1.)*wcg)
      ! ---- Change the dispersion with the new energy
      do i = 1, ngood
        gpai = f(7, i)/xmat
        bpai = sqrt(1.-1./(gpai*gpai))
        fd(i) = bpai/bcour*gpai/gcour
      end do
      ! Test window after the first half sextupole
      call cogetc
      ! Change the t.o.f of the reference
      tref = tref + xlsex/(2.*vref)
      call reject(nlost)
      ! Reshuffles f(i,j) array after window (now done in 'reject')
      ! call shuffle
      call shuffle
      ! second half sextupole
      do ii = 1, ngood
        call clear
        gpai = f(7, ii)/xmat
        bpai = sqrt(1.-1./(gpai*gpai))
        xmco = xmat*bpai*gpai
        ri = 33.356*xmco*1.e-01/f(9, ii)
        ks2 = b/ri
        call elsex
        call cobeam(ii, l)
      end do
      ! Test window after the second half sextupole (only in transverse directions and phase)
      call cogetc
      ! Change the t.o.f of the reference
      tref = tref + xlsex/(2.*vref)
      call reject(ilost)
      ilost = ilost + nlost
      ! Reshuffles f(i,j) array after window (now done in 'reject')
      ! call shuffle
      dav1(idav, 36) = ngood
      write (16, *) 'TOF at output:', tref*fh*180./pi, ' deg'
      write (16, *) ' particles lost in sextupole :', ilost
      ! returns coordinates to the initial orientation
      if (itwist .and. b/=0.) then
        qtwrad = -sqtwist
        call zrotat(qtwrad)
      end if
      if (iemgrw) call emiprt(0)
      call stapl(davtot*10.)
      return
    end subroutine sextu
    ! *******************************************************************
    ! SUBROUTINE qalva(bquad,xlqua,rg)
    ! QUADRUPOLE
    ! space charge computations at the middle of the lens
    ! BQUAD: field at pole tip (kG)
    ! If BQUAD positive = focalisation in the H-plane (x,z)
    ! XLQUA: EFFECTIVE LENGHT (cm )
    ! RG:    APERTURE RADIUS (cm)
    ! *******************************************************************
    subroutine qalva(bquad, xlqua, rg)
      implicit real *8(a-h, o-z)
      parameter(iptsz=100002, maxcell=3000, maxcell1=3000)
      common /fene/wdisp, wphas, wx, wy, rlim, ifw
      common /ttfc/tk, t1k, t2k, sk, s1k, s2k, fh
      common /dyn/tref, vref
      common /consta/vl, pi, xmat, rpel, qst
      common /rigid/boro
      common /faisc/f(10, iptsz), imax, ngood
      common /etcom/cog(8), exten(17), fd(iptsz)
      common /qmoyen/qmoy
      common /dcspa/iesp
      logical iesp
      common /sc3/beamc, scdist, sce10, cplm, ect, apl, ichaes, iscsp
      logical ichaes
      common /tapes/in, ifile, meta
      common /pltprf/sprfx(3000), sprfy(3000), sprfl(3000), sprfw(3000), sprfp(3000), sprng(3000), iprf
      common /davcom/dav1(maxcell1, 40), davtot, iitem(maxcell1), idav
      common /shif/dtiph, shift
      logical shift
      common /compt/nrres, nrtre, nrbunc, nrdbun
      common /rander/ialin
      logical ialin
      common /qskew/qtwist, iqrand, itwist, iaqu
      logical itwist
      common /femt/iemgrw, iemqesg
      logical iemgrw
      common /cgtof/charm(20), cgtdv(20), nbch(20), netac
      common /qsex/l, kq2, ks2
      common /tofev/ttvols
      common /itvole/itvol, imamin
      logical itvol, imamin
      real *8 l, kq2, ks2
      dimension trans(1)
      character *1 cr
      ! print out on terminal of transport element # on one and the same line
      nrtre = nrtre + 1
      cr = char(13)
      write (6, 8254) nrtre, nrres, cr
8254  format ('Transport element:', i5, '      Accelerating element:', i5, a1, $)
      ilost = 0
      ! B : GRADIENT IN kG/cm
      b = bquad/rg
      ! statistics
      if (iprf==1) call stapl(davtot*10.)
      write (16, *) ' ***QUADRUPOLE (magnetic) ***'
      fcpi = fh*180./pi
      if (itvol) write (16, 10) ttvols*fcpi, davtot
10    format (' ** TOF (input of the lens): ', e12.5, ' deg at: ', e12.5, ' cm in the lattice')
      ! if itwist=.true: skews the quadrupole before misalignments (if b ne 0)
      ! len = 1 level in rlux routine
      len = 1
      if (itwist .and. b/=0.) then
        if (iqrand==0) then
          qtwrad = qtwist
          sqtwist = qtwrad
          call zrotat(qtwrad)
        else
          rdcf = .5
          call rlux(trans, len)
          if (trans(1)<=rdcf) sign = -1.
          if (trans(1)>rdcf) sign = 1.
          call rlux(trans, len)
          qtwrad = qtwist*sign*trans(1)
          sqtwist = qtwrad
          call zrotat(qtwrad)
        end if
      else
        sqtwist = 0.
      end if
      if (ialin) call randali
      fh0 = fh/vl
      ! print transport matrix (cog)
      gpa = 0.
      do ii = 1, ngood
        gpa = gpa + f(7, ii)/xmat
      end do
      gpa = gpa/float(ngood)
      l = xlqua
      bpa = sqrt(1.-1./(gpa*gpa))
      xmco = xmat*bpa*gpa
      ri = 33.356*xmco*1.e-01/qst
      kq2 = b/ri
      call clear
      call elqua
      write (16, 3300) xlqua, rg, bquad, kq2, b, ri
3300  format (' LENGTH = ', e12.5, ' cm  APERTURE RADIUS= ', e12.5, ' cm', /, ' FIELD = ', e12.5, ' kG  K2 = ', e12.5, &
        ' cm-2 ', ' GRADIENT = ', e12.5, ' kG/cm', /, ' MOMENTUM = ', e12.5, ' kG.cm', /)
      call matrix
      ! Daves start
      idav = idav + 1
      iitem(idav) = 2
      dav1(idav, 1) = xlqua*10.
      dav1(idav, 2) = bquad
      davtot = davtot + xlqua
      dav1(idav, 4) = davtot*10.
      dav1(idav, 3) = kq2
      dav1(idav, 5) = b
      dav1(idav, 6) = ri
      dav1(idav, 7) = rg*10.
      ! first half quadrupole
      l = xlqua/2.
      do ii = 1, ngood
        call clear
        gpai = f(7, ii)/xmat
        bpai = sqrt(1.-1./(gpai*gpai))
        xmco = xmat*bpai*gpai
        ri = 33.356*xmco*1.e-01/f(9, ii)
        kq2 = b/ri
        call elqua
        call cobeam(ii, l)
      end do
      ! Charge space computations (if dl >0)
      if (ichaes .and. l>0.) then
        if (sce10==1 .or. sce10==3.) then
          iesp = .true.
          write (16, *) 'space charge at the middle  '
          call cesp(xlqua)
          iesp = .false.
          ! Change the dispersion dE/E with respect to the C.O.G of the bunch
          call disp
        end if
      end if
      ! Test window after the first half quadrupole (after s.c. computations)
      call cogetc
      bcour = 0.
      do i = 1, ngood
        gpai = f(7, i)/xmat
        bcour = sqrt(1.-1./(gpai*gpai)) + bcour
      end do
      bcour = bcour/float(ngood)
      gcour = 1./sqrt(1.-bcour*bcour)
      wcg = (gcour-1.)*xmat
      ! ----- window control
      ! Change the t.o.f of the reference
      tref = tref + xlqua/(2.*vref)
      call reject(nlost)
      ! Reshuffles f(i,j) array after window (now done in 'reject')
      ! call shuffle
      ! second half quadrupole
      do ii = 1, ngood
        call clear
        gpai = f(7, ii)/xmat
        bpai = sqrt(1.-1./(gpai*gpai))
        xmco = xmat*bpai*gpai
        ri = 33.356*xmco*1.e-01/f(9, ii)
        kq2 = b/ri
        call elqua
        ! ********CONTROL :print matrix for particle number 1 (only for tests)
        ! omment        if(ii.eq.1) then
        ! omment        write(16,*) ' *****second half quadrupole'
        ! omment         xkq2=sqrt(abs(kq2))
        ! omment         xkql=xkq2*l*57.29578
        ! omment         write(16,3300) ri,xkq2,xkql
        ! omment            call matrix
        ! omment        endif
        call cobeam(ii, l)
      end do
      ! Test window after the second half quadrupole
      call cogetc
      ! Change the t.o.f of the reference
      tref = tref + xlqua/(2.*vref)
      call reject(ilost)
      ilost = ilost + nlost
      ! Reshuffles f(i,j) array after window (now done in 'reject')
      ! call shuffle
      if (itvol) ttvols = tref
      tcog = 0.
      do i = 1, ngood
        tcog = tcog + f(6, i)
      end do
      tcog = tcog/float(ngood)
      if (itvol) then
        write (16, 11) ttvols*fcpi, davtot, tref*fcpi, tcog*fcpi
11      format (' ** tof: ', e12.5, ' deg at: ', e12.5, ' cm in the lattice', /, 3x, 'tof of the reference: ', e12.5, &
          ' deg tof of the cog: ', e12.5, ' deg')
      else
        write (16, 12) tref*fcpi, tcog*fcpi
12      format (' ** tof of the reference: ', e12.5, ' deg tof of the cog: ', e12.5, ' deg')
      end if
      dav1(idav, 36) = ngood
      write (16, *) ' particles lost in quadrupole :', ilost
      ! returns coordinates to the initial orientation
      if (itwist .and. b/=0.) then
        qtwrad = -sqtwist
        call zrotat(qtwrad)
      end if
      if (iemgrw) call emiprt(0)
      ! envelope
      call stapl(davtot*10.)
      return
    end subroutine qalva
    ! *******************************************************************
    ! SUBROUTINE qasex(iksq,args,argq,xlqua,rg)
    ! quadrupole associated sextupole field
    ! space charge computation at the middle of the lens
    ! IKSQ: IFLAG (see ARGS and ARGQ)
    ! ARGS: strength of SEXTUPOLE
    ! IKSQ = 0, then ARGS =KS2 (cm-3), otherwise ARGS = FIELD FS(kG)
    ! ARGQ: strength of QUADRUPOLE
    ! If IKSQ = 0, then ARGQ=KQ2 (cm-2), otherwise ARGQ = FIELD FQ(kG)
    ! XLQUA : EFFECTIVE LENGHT OF THE LENS(cm)
    ! RG : APERTURE RADIUS OF THE LENS (cm)
    ! *******************************************************************
    subroutine qasex(iksq, args, argq, xlqua, rg)
      implicit real *8(a-h, o-z)
      parameter(iptsz=100002, maxcell=3000, maxcell1=3000)
      common /fene/wdisp, wphas, wx, wy, rlim, ifw
      common /ttfc/tk, t1k, t2k, sk, s1k, s2k, fh
      common /dyn/tref, vref
      common /consta/vl, pi, xmat, rpel, qst
      common /rigid/boro
      common /faisc/f(10, iptsz), imax, ngood
      common /etcom/cog(8), exten(17), fd(iptsz)
      common /qmoyen/qmoy
      common /dcspa/iesp
      logical iesp
      common /sc3/beamc, scdist, sce10, cplm, ect, apl, ichaes, iscsp
      logical ichaes
      common /tapes/in, ifile, meta
      common /pltprf/sprfx(3000), sprfy(3000), sprfl(3000), sprfw(3000), sprfp(3000), sprng(3000), iprf
      common /davcom/dav1(maxcell1, 40), davtot, iitem(maxcell1), idav
      common /shif/dtiph, shift
      logical shift
      common /compt/nrres, nrtre, nrbunc, nrdbun
      common /rander/ialin
      logical ialin
      common /qskew/qtwist, iqrand, itwist, iaqu
      logical itwist
      common /femt/iemgrw, iemqesg
      logical iemgrw
      common /cgtof/charm(20), cgtdv(20), nbch(20), netac
      common /qsex/l, kq2, ks2
      real *8 l, kq2, ks2
      character *1 cr
      ! print out on terminal of transport element # on one and the same line
      nrtre = nrtre + 1
      cr = char(13)
      write (6, 8254) nrtre, nrres, cr
8254  format ('Transport element:', i5, '      Accelerating element:', i5, a1, $)
      rgorge = rg
      ilost = 0
      ! statistics
      if (iprf==1) call stapl(davtot*10.)
      ! if itwist=.true. skews the quasex before misalignments
      ! omment       len=1
      ! omment       if(itwist.and.b.ne.0.) then
      ! omment         if(iqrand.eq.0) then
      ! omment           qtwrad=qtwist
      ! omment           sqtwist=qtwrad
      ! omment           call zrotat(qtwrad)
      ! omment         else
      ! omment           rdcf=.5
      ! omment           call rlux(trans,len)
      ! omment           if(trans.le.rdcf) sign=-1.
      ! omment           if(trans.gt.rdcf) sign=1.
      ! omment           call rlux(trans,len)
      ! omment           qtwrad=qtwist*sign*trans
      ! omment           sqtwist=qtwrad
      ! omment           call zrotat(qtwrad)
      ! omment         endif
      ! omment       endif
      ! misalignments
      if (ialin) call randali
      gpa = 0.
      do ii = 1, ngood
        gpa = gpa + f(7, ii)/xmat
      end do
      gpa = gpa/float(ngood)
      l = xlqua
      bpa = sqrt(1.-1./(gpa*gpa))
      xmco = xmat*bpa*gpa
      ri = 33.356*xmco*1.e-01/qst
      if (iksq/=0) then
        ! --- quadrupole: argq = field fq (kG)
        fq = argq
        bq = fq/rg
        ! kq2: strength (cm-2)
        kq2 = bq/ri
        ! --- sextupole: args = field fs (kG)
        fs = args
        bs = fs/(rg*rg)
        ! ks2 strength (cm-3)
        ks2 = bs/ri
      else
        ! --- quadrupole: argq is kq2 (cm-2)
        kq2 = argq
        fq = kq2*rg*ri
        bq = kq2*ri
        ! --- sextupole: args is ks2 (cm-3)
        ks2 = args
        bs = ks2*ri
        fs = bs*(rg*rg)
      end if
      call clear
      call elqsex
      write (16, *) ' *****LENS QUADRUPOLE+SEXTUPOLE ********'
      write (16, 3300) xlqua, rg, fq, kq2, bq, fs, ks2, bs, ri
3300  format (' LENS: LENGTH = ', e12.5, ' cm APERTURE RADIUS = ', e12.5, ' cm', /, ' QUADRUPOLE: FIELD = ', e12.5, &
        ' kG   KQ2 = ', e12.5, ' cm-2  GRADIENT = ', e12.5, ' kG/cm', /, ' SEXTUPOLE: FIELD = ', e12.5, ' kG   KS2 = ', &
        e12.5, ' cm-3', ' GRADIENT = ', e12.5, ' kG/(cm*cm)', /, ' MOMENTUM = ', e12.5, ' kG.cm', /)
      fh0 = fh/vl
      write (16, *) 'TOF at input:', tref*fh*180./pi, ' deg'
      ! print transport matrix  (c.o.g.)
      call matrix
      ! start Daves
      idav = idav + 1
      iitem(idav) = 12
      dav1(idav, 1) = xlqua*10.
      dav1(idav, 6) = rg*10.
      dav1(idav, 2) = fq
      dav1(idav, 3) = kq2
      ! gradient (quad)       dav1(idav,5)=bq
      dav1(idav, 7) = fs
      dav1(idav, 8) = ks2
      ! gradient (sol)       dav1(idav,9)=bs
      dav1(idav, 10) = ri
      davtot = davtot + xlqua
      dav1(idav, 4) = davtot*10.
      ! first half quasex
      l = xlqua/2.
      do ii = 1, ngood
        call clear
        gpai = f(7, ii)/xmat
        bpai = sqrt(1.-1./(gpai*gpai))
        xmco = xmat*bpai*gpai
        ri = 33.356*xmco*1.e-01/f(9, ii)
        kq2 = bq/ri
        ks2 = bs/ri
        call elqsex
        ! ********CONTROL :print matrix for particle number 1 (only for tests)
        ! omment        if(ii.eq.5) then
        ! omment         write(16,*) ' *****first half quasex'
        ! omment         xkq2=sqrt(abs(kq2))
        ! omment         xkql=xkq2*l*57.29578
        ! omment         xks=sqrt(abs(ks2))
        ! omment         xksl=xks*l**(1.5)*57.29578
        ! omment         write(16,3300) ri,xkq2,xkql,xks,xksl
        ! omment         call matrix
        ! omment        endif
        ! ********END CONTROL
        call cobeam(ii, l)
      end do
      ! Charge space effect (if dl >0)
      if (ichaes .and. l>0.) then
        if (sce10==1 .or. sce10==3.) then
          iesp = .true.
          write (16, *) 'space charge at the middle  '
          call cesp(xlqua)
          iesp = .false.
          ! Change the dispersion dE/E with respect to the C.O.G of the bunch
          call disp
        end if
      end if
      ! Test window after the first half quasex (after s.c. computations)
      bcour = 0.
      do i = 1, ngood
        gpai = f(7, i)/xmat
        bcour = sqrt(1.-1./(gpai*gpai)) + bcour
      end do
      bcour = bcour/float(ngood)
      gcour = 1./sqrt(1.-bcour*bcour)
      wcg = (gcour-1.)*xmat
      ! ----- window control
      call cogetc
      ! Change the t.o.f of the reference
      tref = tref + xlqua/(2.*vref)
      call reject(nlost)
      ! Reshuffles f(i,j) array after window (now done in 'reject')
      ! call shuffle
      ! second half quasex
      do ii = 1, ngood
        call clear
        gpai = f(7, ii)/xmat
        bpai = sqrt(1.-1./(gpai*gpai))
        xmco = xmat*bpai*gpai
        ri = 33.356*xmco*1.e-01/f(9, ii)
        kq2 = bq/ri
        ks2 = bs/ri
        call elqsex
        ! ********CONTROL :print matrix for particle number 1 (only for tests)
        ! omment        if(ii.eq.5) then
        ! omment         write(16,*) ' *****second half quasex'
        ! omment         xkq2=sqrt(abs(kq2))
        ! omment         xkql=xkq2*l*57.29578
        ! omment         xks=sqrt(abs(ks2))
        ! omment         xksl=xks*l**(1.5)*57.29578
        ! omment         write(16,3300) ri,xkq2,xkql,xks,xksl
        ! omment            call matrix
        ! omment        endif
        ! ********END CONTROL
        call cobeam(ii, l)
      end do
      ! Test window after the second half quasex (only in transverse directions and phase)
      call cogetc
      ! Change the t.o.f of the reference
      tref = tref + xlqua/(2.*vref)
      call reject(ilost)
      ilost = ilost + nlost
      ! Reshuffles f(i,j) array after window (now done in 'reject')
      ! call shuffle
      dav1(idav, 36) = ngood
      write (16, *) 'TOF at output:', tref*fh*180./pi, ' deg'
      write (16, *) ' particles lost:', ilost
      ! returns coordinates to the initial orientation
      ! omment       if(itwist.and.b.ne.0.) then
      ! omment         qtwrad=-sqtwist
      ! omment         call zrotat(qtwrad)
      ! omment       endif
      if (iemgrw) call emiprt(0)
      call stapl(davtot*10.)
      return
    end subroutine qasex
    ! *******************************************************************
    ! SUBROUTINE ELQUA
    ! FIRST AND SECOND order TRANSPORT MATRIX R AND T
    ! PURE QUADRUPOLE FIELD, MATRIX R AND T  ARE IN  (M,RD)
    ! **** WARNING : IN THIS ROUTINE ALL VARIABLES ARE REAL UNLESS
    ! OTHERWIZE DECLARED *********
    ! *******************************************************************
    subroutine elqua
      implicit real *8(a-z)
      common /qsex/l, kq2, ks2
      common /bloc11/r(6, 6), t(6, 6, 6)
      common /secdr/iseor
      logical iseor

      akq2 = kq2*1.e04
      al = l*1.e-02
      akq = sqrt(abs(akq2))
      if (akq<1.e-13) akq = 1.e-13
      arg = akq*al
      csin = sin(arg)
      ccos = cos(arg)
      hsin = sinh(arg)
      hcos = cosh(arg)
      if (akq2>0.0) then
        ssok = csin/akq
        sc = ccos
        bsok = hsin/akq
        bc = hcos
      else
        ssok = hsin/akq
        sc = hcos
        bsok = csin/akq
        bc = ccos
      end if
      r(1, 1) = sc
      r(1, 2) = ssok
      r(2, 1) = -akq2*ssok
      r(2, 2) = sc
      r(3, 3) = bc
      r(3, 4) = bsok
      r(4, 3) = akq2*bsok
      r(4, 4) = bc
      if (.not. iseor) return
      ! T116=AMAT(12,1)
      t(1, 1, 6) = al*akq2*ssok/2.0
      ! T126=AMAT(17,1)
      t(1, 2, 6) = (ssok-al*sc)/2.0
      ! T216=AMAT(12,2)
      t(2, 1, 6) = akq2*(ssok+al*sc)/2.0
      ! T226=AMAT(17,2)
      t(2, 2, 6) = t(1, 1, 6)
      ! T336= AMAT(21,3) T346=AMAT(24,3)
      t(3, 3, 6) = -al*akq2*bsok/2.0
      t(3, 4, 6) = (bsok-al*bc)/2.0
      ! T436=AMAT(21,4)  T446=AMAT(24,4)
      t(4, 3, 6) = -akq2*(bsok+al*bc)/2.0
      t(4, 4, 6) = t(3, 3, 6)
      ! T511=AMAT(7,5)  T512=AMAT(8,5) T522=AMAT(13,5) T533=AMAT(18,5)
      t(5, 1, 1) = akq2*(al-sc*ssok)/4.0
      t(5, 1, 2) = -akq2*ssok*ssok/2.0
      t(5, 2, 2) = (al+sc*ssok)/4.0
      t(5, 3, 3) = -akq2*(al-bc*bsok)/4.0
      ! T534=AMAT(19,5)  T544=AMAT(22,5)
      t(5, 3, 4) = akq2*(bsok*bsok)/2.0
      t(5, 4, 4) = (al+bc*bsok)/4.0
      return
    end subroutine elqua
    ! *******************************************************************
    ! SUBROUTINE ELSEX
    ! FIRST AND SECOND order TRANSPORT MATRIX R AND T
    ! PURE SEXTUPOLE FIELD, MATRIX R AND T  ARE IN  (M,RD)
    ! **** WARNING : IN THIS ROUTINE ALL VARIABLES ARE REAL UNLESS
    ! OTHERWIZE DECLARED *********
    ! *******************************************************************
    subroutine elsex
      implicit real *8(a-z)
      common /qsex/l, kq2, ks2
      common /bloc11/r(6, 6), t(6, 6, 6)
      common /secdr/iseor
      common /elq/inisk
      integer inisk
      logical iseor

      if (inisk==0) then
        aks2 = ks2*1.e06
        al = l*1.e-02
      else
        inisk = 0
      end if
      ! 1000  CONTINUE
      akl1 = aks2*al
      akl2 = akl1*al
      akl3 = akl2*al
      akl4 = akl3*al
      r(1, 2) = al
      r(3, 4) = al
      if (.not. iseor) return
      ! T522=AMAT(13,5) T544=AMAT(22,5)
      t(5, 2, 2) = al/2.0
      t(5, 4, 4) = al/2.0
      if (aks2==0.0) return
      ! T111=AMAT( 7,1) T112=AMAT( 8,1) T122=AMAT(13,1)
      t(1, 1, 1) = -akl2/2.0
      t(1, 1, 2) = -akl3/3.0
      t(1, 2, 2) = -akl4/12.0
      ! T133=AMAT(18,1)  T134=AMAT(19,1)  T144=AMAT(22,1)
      t(1, 3, 3) = akl2/2.0
      t(1, 3, 4) = akl3/3.0
      t(1, 4, 4) = akl4/12.0
      ! T211=AMAT( 7,2) T212=AMAT( 8,2) T222=AMAT(13,2)
      t(2, 1, 1) = -akl1
      t(2, 1, 2) = -akl2
      t(2, 2, 2) = -akl3/3.0
      ! T233=AMAT(18,2) T234=AMAT(19,2) T244=AMAT(22,2)
      t(2, 3, 3) = akl1
      t(2, 3, 4) = akl2
      t(2, 4, 4) = akl3/3.0
      ! T313=AMAT( 9,3) T314=AMAT( 10,3)  T323=AMAT(14,3) T324=AMAT(15,3)
      t(3, 1, 3) = akl2
      t(3, 1, 4) = akl3/3.0
      t(3, 2, 3) = akl3/3.0
      t(3, 2, 4) = akl4/6.0
      ! T413=AMAT(9,4) T414=AMAT( 10,4) T423=AMAT(14,4) T424=AMAT(15,4)
      t(4, 1, 3) = akl1*2.0
      t(4, 1, 4) = akl2
      t(4, 2, 3) = akl2
      t(4, 2, 4) = akl3*2.0/3.0
      return
    end subroutine elsex
    ! *******************************************************************
    ! SUBROUTINE ELQSEX
    ! FIRST AND SECOND order TRANSPORT MATRIX R AND T
    ! QUADRUPOLE FIELD  + SEXTUPOLE FIELD
    ! quadrupole field combined with a sextupole field
    ! **** WARNING : IN THIS ROUTINE ALL VARIABLES ARE REAL UNLESS
    ! OTHERWIZE DECLARED *********
    ! *******************************************************************
    subroutine elqsex
      implicit real *8(a-z)
      common /qsex/l, kq2, ks2
      common /bloc11/r(6, 6), t(6, 6, 6)
      common /secdr/iseor
      common /elq/inisk
      integer inisk
      logical iseor

      aks2 = ks2*1.e06
      al = l*1.e-02
      akq2 = kq2*1.e04
      akq = sqrt(abs(akq2))
      arg = akq*al
      csin = sin(arg)
      ccos = cos(arg)
      hsin = sinh(arg)
      hcos = cosh(arg)
      if (akq2>6.*0) then
        ssok = csin/akq
        sc = ccos
        bsok = hsin/akq
        bc = hcos
      else
        ssok = hsin/akq
        sc = hcos
        bsok = csin/akq
        bc = ccos
      end if
      if (akq2==6.*0) then
        r(1, 2) = al
        r(3, 4) = al
      else
        r(1, 1) = sc
        r(1, 2) = ssok
        r(2, 1) = -akq2*ssok
        r(2, 2) = sc
        r(3, 3) = bc
        r(3, 4) = bsok
        r(4, 3) = akq2*bsok
        r(4, 4) = bc
      end if
      if (.not. iseor) return
      ! omment       IF(KS2.EQ.0.0)RETURN
      if (akq2==6.*0) then
        inisk = 1
        call elsex
      else
        ! T111=AMAT( 7,1)  T112=AMAT( 8,1) T116=AMAT(12,1)
        t(1, 1, 1) = -aks2*(ssok*ssok+(1.0-sc)/akq2)/3.0
        t(1, 1, 2) = -2.0*aks2*(ssok*(1.0-sc)/akq2)/3.0
        t(1, 1, 6) = al*akq2*ssok/2.0
        ! T122=AMAT(13,1) T126=AMAT(17,1)
        t(1, 2, 2) = -aks2*(2.0*(1.0-sc)/akq2-ssok*ssok)/(3.0*akq2)
        t(1, 2, 6) = (ssok-al*sc)/2.0
        ! T133=AMAT(18,1) T134=AMAT(19,1) T144=AMAT(22,1)
        t(1, 3, 3) = aks2*(bsok*bsok+3.0*(1.0-sc)/akq2)/5.0
        t(1, 3, 4) = 2.0*aks2*(bsok*bc-ssok)/(5.0*akq2)
        t(1, 4, 4) = aks2*(bsok*bsok-2.0*(1.0-sc)/akq2)/(5.0*akq2)
        ! T211=AMAT( 7,2) T212= AMAT( 8,2) T216=AMAT(12,2)
        t(2, 1, 1) = -aks2*(2.0*ssok*sc+ssok)/3.0
        t(2, 1, 2) = -2.0*aks2*(sc*(1.0-sc)/akq2+ssok*ssok)/3.0
        t(2, 1, 6) = akq2*(ssok+al*sc)/2.0
        ! T222=AMAT(13,2)  T226=AMAT(17,2)
        t(2, 2, 2) = -aks2*(2.0*ssok-2.0*ssok*sc)/(3.0*akq2)
        t(2, 2, 6) = t(1, 1, 6)
        ! T233=AMAT(18,2) T234=AMAT(19,2) T244=AMAT(22,2)
        t(2, 3, 3) = aks2*(2.0*bsok*bc+3.0*ssok)/5.0
        t(2, 3, 4) = 2.0*aks2*(bc*bc+bsok*bsok*akq2-sc)/(5.0*akq2)
        t(2, 4, 4) = 2.0*aks2*(bsok*bc-ssok)/(5.0*akq2)
        ! T313=AMAT(9,3)   T314=AMAT(10,3)  T323=AMAT(14,3)
        t(3, 1, 3) = 2.0*aks2*(bc*(1.0-sc)/akq2+2.0*ssok*bsok)/5.0
        t(3, 1, 4) = 2.0*aks2*(2.0*ssok*bc-bsok*(1.0+sc))/(5.0*akq2)
        t(3, 2, 3) = 2.0*aks2*(3.0*bsok-2.0*bsok*sc-ssok*bc)/(5.0*akq2)
        ! T324=AMAT(15,3) T336= AMAT(21,3) T346=AMAT(24,3)
        t(3, 2, 4) = 2.0*aks2*(2.0*bc*(1.0-sc)/akq2-ssok*bsok)/(5.0*akq2)
        t(3, 3, 6) = -al*akq2*bsok/2.0
        t(3, 4, 6) = (bsok-al*bc)/2.0
        ! T413=AMAT( 9,4)  T414=AMAT(10,4)  T423=AMAT(14,4)    T424=AMAT(15,4)
        t(4, 1, 3) = 2.0*aks2*(bsok*(1.0-sc)+bc*ssok+2.0*sc*bsok+2.0*ssok*bc)/5.0
        t(4, 1, 4) = 2.0*aks2*(2.0*sc*bc+2.0*ssok*bsok*akq2-bc*(1.0+sc)+bsok*ssok*akq2)/(5.0*akq2)
        t(4, 2, 3) = 2.0*aks2*(3.0*bc-2.0*bc*sc+2.0*bsok*ssok*akq2-sc*bc-ssok*bsok*akq2)/(5.0*akq2)
        t(4, 2, 4) = 2.0*aks2*(2.0*bsok*(1.0-sc)+2.0*bc*ssok-sc*bsok-ssok*bc)/(5.0*akq2)
        ! T436=AMAT(21,4)  T446=AMAT(24,4)
        t(4, 3, 6) = -akq2*(bsok+al*bc)/2.0
        t(4, 4, 6) = t(3, 3, 6)
        ! T511=AMAT(7,5)  T512=AMAT(8,5) T522=AMAT(13,5) T533=AMAT(18,5)
        t(5, 1, 1) = akq2*(al-sc*ssok)/4.0
        t(5, 1, 2) = -akq2*ssok*ssok/2.0
        t(5, 2, 2) = (al+sc*ssok)/4.0
        t(5, 3, 3) = -akq2*(al-bc*bsok)/4.0
        ! T534=AMAT(19,5)  T544=AMAT(22,5)
        t(5, 3, 4) = akq2*(bsok*bsok)/2.0
        t(5, 4, 4) = (al+bc*bsok)/4.0
      end if
      return
    end subroutine elqsex
    ! *******************************************************************
    ! SUBROUTINE solfield(bcret,intgr)
    ! Solenoid with an arbitrary magnetic field
    ! *******************************************************************
    subroutine solfield(bcret, intgr)
      implicit real *8(a-h, o-z)
      parameter(iptsz=100002, maxcell=3000, maxcell1=3000)
      common /ttfc/tk, t1k, t2k, sk, s1k, s2k, fh
      common /fene/wdisp, wphas, wx, wy, rlim, ifw
      common /dyn/tref, vref
      common /rigid/boro
      common /dcspa/iesp
      common /faisc/f(10, iptsz), imax, ngood
      common /etcom/cog(8), exten(17), fd(iptsz)
      common /qmoyen/qmoy
      common /consta/vl, pi, xmat, rpel, qst
      common /tapes/in, ifile, meta
      common /pltprf/sprfx(3000), sprfy(3000), sprfl(3000), sprfw(3000), sprfp(3000), sprng(3000), iprf
      common /davcom/dav1(maxcell1, 40), davtot, iitem(maxcell1), idav
      common /shif/dtiph, shift
      common /rander/ialin
      common /femt/iemgrw, iemqesg
      common /cgtof/charm(20), cgtdv(20), nbch(20), netac
      common /compt/nrres, nrtre, nrbunc, nrdbun
      common /sc3/beamc, scdist, sce10, cplm, ect, apl, ichaes, iscsp
      common /spl/xspl(4000), yspl(4000), s(5000), p(5000), q(5000)
      common /bloc11/r(6, 6), t(6, 6, 6)
      dimension rs(6, 6), rcul(6, 6)
      logical iesp, ichaes, shift, ialin, iemgrw
      character *1 cr
      ! print out on terminal of transport element # on one and the same line
      nrtre = nrtre + 1
      cr = char(13)
      write (6, 8254) nrtre, nrres, cr
8254  format ('Transport element:', i5, '      Accelerating element:', i5, a1, $)
      ! read the magnetic field on the disk
      read (25, *) ncord
      if (ncord==0) then
        rewind(25)
        read (25, *) ncord
      end if
      crest = 0.
      do i = 1, ncord
        read (25, *) xspl(i), yspl(i)
        if (yspl(i)>crest) crest = yspl(i)
      end do
      zinf = xspl(1)
      zsup = xspl(ncord)
      call deriv2(ncord)
      npas = intgr
      dsol = (zsup-zinf)/float(npas)
      xlsol = (zsup-zinf)*100.
      write (16, 101) xlsol, crest, bcret
101   format (5x, 'Field length =', f7.3, ' cm ', /, 5x, 'Crest of the field =', f10.4, ' kG', /5x, &
        'Attenuation factor =', f10.4, /)
      fh0 = fh/vl
      ! random errors in alignment
      if (ialin) call randali
      ! test window
      ilost = 0
      ! PLOT
      if (iprf==1) call stapl(davtot*10.)
      ! start prints in file 'short.data'
      idav = idav + 1
      iitem(idav) = 5
      dav1(idav, 1) = xlsol*10.
      dav1(idav, 2) = crest
      davti = davtot
      davtot = davtot + xlsol
      dav1(idav, 4) = davtot*10.
      zc = zinf
      iesp = .true.
      do ia = 1, 6
        do ib = 1, 6
          if (ia==ib) rcul(ia, ib) = 1.
          if (ia/=ib) rcul(ia, ib) = 0.
        end do
      end do
      bisol = 0.
      bisol2 = 0.
      fnpas = float(npas)
      do i = 1, npas
        zcf = zc + dsol
        zcf2 = zc + dsol/2.
        bsol = bcret*spline(ncord, zcf2)
        ! omment        write(70,110) i,zcf2,bsol
        dscm = dsol*100.
        tref = tref + xlsol/(vref*fnpas)
        call fldsol(bsol, dscm)
        write (16, 520) i, zc, zcf, bsol
520     format (2x, '**STEP: ', i2, ' LIMITS: inf(m)= ', f7.5, ' sup(m)= ', f7.5, ' AVERAGE FIELD(kG): ', e12.5)
        bisol = bisol + bsol*dsol
        bisol2 = bisol2 + bsol*bsol*dsol
        ! save equivalent transport matrix
        do ia = 1, 6
          do ib = 1, 6
            rs(ia, ib) = rcul(ia, ib)
          end do
        end do
        call mfordre(rcul, r, rs)
        ! ************TEST******************
        ! print first order matrix
        ! omment         write(16,*) ' EQUIVALENT FIRST order MATRIX TRANSFORM (m-rad)'
        ! omment       skl=0.5*acos(2.*r(1,1)-1.)*57.29578
        ! omment       write(16,*) '**** K*LENGTH: ',skl,' degrees'
        ! omment       DO IA=1,6
        ! omment        write(16,100) (r(ia,ib),ib=1,6)
        ! omment       ENDDO
        ! omment        write(16,*) '*******cumul***************'
        ! omment         DO IA=1,6
        ! omment         write(16,100) (rcul(ia,ib),ib=1,6)
        ! omment         ENDDO
        ! **********END TEST********************
        ! SPACE CHARGE
        if (.not. iesp) then
          iesp = .true.
          go to 720
        end if
        if (ichaes .and. xlsol>0.) then
          if (sce10==1 .or. sce10==3.) then
            dscm2 = dscm*2.
            call cesp(dscm2)
            iesp = .false.
            ! dispersion dE/E with respect to the C.O.G of the bunch
            call disp
          end if
        end if
720     continue
        ! envelope sol
        write (16, *) 'distance', davti, dsol
        davti = davti + dsol*100.
        call stapl((davti)*10.)
        zc = zcf
      end do
      write (16, 922) zc, bisol, bisol2, bisol2/zc
922   format (/, 'Field length                 (m): ', e12.5, /, 'Field integral            (kG.m): ', e12.5, /, &
        'Field squared integral (kG**2.m): ', e12.5, /, 'Field squared integral/L (kG**2): ', e12.5, /)
      ! 110    format(2x,i5,2(2x,e12.5))
      ! print first order matrix
      write (16, *) ' EQUIVALENT FIRST order MATRIX TRANSFORM (m-rad)'
      skl = 0.5*acos(2.*rcul(1,1)-1.)*57.29578
      write (16, *) ' ******* K*LENGTH: ', skl, ' degrees'
      do ia = 1, 6
        write (16, 100)(rcul(ia,ib), ib=1, 6)
      end do
100   format (6(3x,e12.5))
      ! **************************************************
      ! evolution of the t.o.f of the reference (moved inside loop - Alt)
      ! TREF=TREF+XLSOL/VREF
      dav1(idav, 36) = ngood
      ! plots
      call stapl(davtot*10.)
      if (iemgrw) call emiprt(0)
      write (16, *) 'particles lost in solenoid', ilost
      return
    end subroutine solfield
    ! *******************************************************************
    ! SUBROUTINE fldsol(dbs,step)
    ! solenoidal field
    ! *******************************************************************
    subroutine fldsol(dbs, step)
      implicit real *8(a-h, o-z)
      parameter(iptsz=100002, maxcell=3000, maxcell1=3000)
      common /faisc/f(10, iptsz), imax, ngood
      common /fene/wdisp, wphas, wx, wy, rlim, ifw
      common /consta/vl, pi, xmat, rpel, qst
      common /etcom/cog(8), exten(17), fd(iptsz)
      common /femt/iemgrw, iemqesg
      common /cgtof/charm(20), cgtdv(20), nbch(20), netac
      common /sole/l, kl, ko
      real *8 l, kl, ko

      l = step
      b = dbs
      gpai = 0.
      do ii = 1, ngood
        gpai = gpai + f(7, ii)/xmat
      end do
      gpai = gpai/float(ngood)
      bpai = sqrt(1.-1./(gpai*gpai))
      xmco = xmat*bpai*gpai
      ri = 33.356*xmco*1.e-01/qst
      ko = b/ri
      if (ko==0.) ko = 1.e-16
      kl = ko*l
      ! half step
      ! omment       kl=kl/2.
      call clear
      call elsol
      do ii = 1, ngood
        ! **********
        ! omment        call clear
        ! omment        gpai=f(7,ii)/xmat
        ! omment        bpai=sqrt(1.-1./(gpai*gpai))
        ! omment        xmco=xmat*bpai*gpai
        ! omment        RI=33.356*XMCO*1.E-01/f(9,ii)
        ! omment        KO = B /RI
        ! omment        IF(KO .EQ. 0.) KO=1.E-16
        ! omment        kl=ko*l
        ! omment        call elsol
        ! ***************
        call cobeam(ii, l)
        ! evolution of the t.o.f has been made in the routine cobeam
        ! omment         f(6,ii)=f(6,ii)+step/(bpai*vl)
      end do
      ! test window after the step (only in the transverse directions)
      call cogetc
      call reject(ilost)
      ! Reshuffles f(i,j) array after window (now done in 'reject')
      ! call shuffle
      return
    end subroutine fldsol
    ! *******************************************************************
    ! SUBROUTINE solnoid(imks,arg,xlsol)
    ! SOLENOID (fringe-fields are included in the transport matrix)
    ! space charge computations at the middle of the lens
    ! IMKS: IFLAG (see ARG)
    ! ARG:  IMKS = 0 then ARG is K (cm-1), otherwise ARG is the
    ! field BSOL (kG)
    ! XLSOL : EFFECTIVE LENGHT (CM )
    ! *******************************************************************
    subroutine solnoid(imks, arg, xlsol)
      implicit real *8(a-h, o-z)
      parameter(iptsz=100002, maxcell=3000, maxcell1=3000)
      common /ttfc/tk, t1k, t2k, sk, s1k, s2k, fh
      common /fene/wdisp, wphas, wx, wy, rlim, ifw
      common /dyn/tref, vref
      common /rigid/boro
      common /dcspa/iesp
      common /faisc/f(10, iptsz), imax, ngood
      common /etcom/cog(8), exten(17), fd(iptsz)
      common /qmoyen/qmoy
      common /consta/vl, pi, xmat, rpel, qst
      common /tapes/in, ifile, meta
      common /pltprf/sprfx(3000), sprfy(3000), sprfl(3000), sprfw(3000), sprfp(3000), sprng(3000), iprf
      common /davcom/dav1(maxcell1, 40), davtot, iitem(maxcell1), idav
      common /shif/dtiph, shift
      common /rander/ialin
      common /femt/iemgrw, iemqesg
      common /cgtof/charm(20), cgtdv(20), nbch(20), netac
      common /compt/nrres, nrtre, nrbunc, nrdbun
      common /sc3/beamc, scdist, sce10, cplm, ect, apl, ichaes, iscsp
      common /bloc11/r(6, 6), t(6, 6, 6)
      common /itvole/itvol, imamin
      common /tofev/ttvols
      common /trace3d/trace3h(100), trace3t(maxcell1), tif, kt3h, kt3t, fid
      character *128 trace3h, trace3t, tif
      logical itvol, imamin
      ! dimension rs(6,6),rcul(6,6)
      logical iesp, ichaes, shift, ialin, iemgrw
      character *1 cr
      common /sole/l, kl, ko
      real *8 l, kl, ko
      ! print out on terminal of transport element # on one and the same line
      nrtre = nrtre + 1
      cr = char(13)
      ! print out on terminal of transport element # on one and the same line
      write (6, 8254) nrtre, nrres, cr
8254  format ('Transport element:', i5, '      Accelerating element:', i5, a1, $)
      write (16, *) ' ****** SOLENOID *********'
      ! PLOT
      if (iprf==1) call stapl(davtot*10.)
      ilost = 0
      fh0 = fh/vl
      fcpi = fh*180./pi
      ! random errors in alignment
      if (ialin) call randali
      ! print out transport matrix (cog)
      gpa = 0.
      do ii = 1, ngood
        gpa = gpa + f(7, ii)/xmat
      end do
      gpa = gpa/float(ngood)
      l = xlsol
      bpa = sqrt(1.-1./(gpa*gpa))
      xmco = xmat*bpa*gpa
      ri = 33.356*xmco*1.e-01/qst
      if (imks/=0) then
        ! ARG is the field B (kG)
        b = arg
        ! KO = 2 * K (see ELSOL)
        ko = b/ri
        if (ko==0.) ko = 1.e-16
      else
        ! ARG is the strength K (cm-1)
        ! KO = 2 * K (see ELSOL)
        ko = 2.*arg
        if (ko==0.) ko = 1.e-16
        b = ko*ri
      end if
      kl = ko*l
      call clear
      call elsol
      xkql = (kl/2.)*57.29578
      ! trace3d
      kt3t = kt3t + 1
      write (tif, 6002) kt3t, kt3t, b*1000., 10.*xlsol
6002  format ('  nt(', i4, ')= 5, a(1,', i4, ')= ', f12.5, ' , ', f9.5)
      trace3t(kt3t) = tif

      write (16, 101) xlsol, b, ko/2., ri, xkql
101   format ('  LENGTH = ', f7.3, ' CM ', /, '  FIELD = ', f10.4, ' KG', /, '  K = ', e12.5, ' cm-1', /, &
        '  MOMENTUM = ', e12.5, ' kG.cm', /, '  TRANSVERSE COORDINATES ROTATION = ', e12.5, ' deg', /)
      call matrix
      write (16, 10) ttvols*fcpi, davtot
10    format (' ** time of flight (input): ', e12.5, ' deg  position: ', e12.5, ' cm')
      ! start prints in file 'short.data'
      idav = idav + 1
      iitem(idav) = 5
      dav1(idav, 1) = xlsol*10.
      dav1(idav, 2) = b
      dav1(idav, 3) = ko/2.
      davtot = davtot + xlsol
      dav1(idav, 4) = davtot*10.
      dav1(idav, 5) = ri
      ! first half solenoid
      dg = xlsol
      l = xlsol/2.
      do ii = 1, ngood
        call clear
        gpai = f(7, ii)/xmat
        bpai = sqrt(1.-1./(gpai*gpai))
        xmco = xmat*bpai*gpai
        ri = 33.356*xmco*1.e-01/f(9, ii)
        ko = b/ri
        if (ko==0.) ko = 1.e-16
        kl = ko*l
        call elsol
        call cobeam(ii, l)
        ! evolution of the t.o.f is made in routine cbeam
        ! omment         f(6,ii)=f(6,ii)+l/(bpai*vl)
      end do
      ! space charge computations (only if l >0)
      if (ichaes .and. l>0.) then
        if (sce10==1 .or. sce10==3.) then
          iesp = .true.
          write (16, *) 'space charge at the middle  '
          call cesp(xlsol)
          iesp = .false.
          ! Change the dispersion dE/E with respect to the C.O.G of the bunch
          call disp
        end if
      end if
      ! test window after the first half solenoid
      call cogetc
      bcour = 0.
      do i = 1, ngood
        gpai = f(7, i)/xmat
        bcour = sqrt(1.-1./(gpai*gpai)) + bcour
      end do
      bcour = bcour/float(ngood)
      gcour = 1./sqrt(1.-bcour*bcour)
      wcg = (gcour-1.)*xmat
      ! ----- window control
      tref = tref + xlsol/(vref*2.)
      call reject(ilost)
      ! Reshuffles f(i,j) array after window (now done in 'reject')
      ! call shuffle
      ! second half solenoid
      do ii = 1, ngood
        call clear
        gpai = f(7, ii)/xmat
        bpai = sqrt(1.-1./(gpai*gpai))
        xmco = xmat*bpai*gpai
        ri = 33.356*xmco*1.e-01/f(9, ii)
        ko = b/ri
        if (ko==0.) ko = 1.e-16
        kl = ko*l
        call elsol
        call cobeam(ii, l)
      end do
      ! t.o.f
      tref = tref + xlsol/(vref*2.)
      call reject(ilost)
      if (itvol) ttvols = tref
      tcog = 0.
      do i = 1, ngood
        tcog = tcog + f(6, i)
      end do
      tcog = tcog/float(ngood)
      if (itvol) then
        write (16, 11) ttvols*fcpi, davtot, tref*fcpi, tcog*fcpi
11      format (' ** tof for adjustments: ', e12.5, ' deg at position: ', e12.5, ' cm in the lattice', /, 3x, &
          'tof of the reference: ', e12.5, ' deg tof of the cog: ', e12.5, ' deg')
      else
        write (16, 12) tref*fcpi, tcog*fcpi
12      format (' ** tof of the reference: ', e12.5, ' deg tof of the cog: ', e12.5, ' deg')
      end if
      dav1(idav, 36) = ngood
      ! plots
      call stapl(davtot*10.)
      if (iemgrw) call emiprt(0)
      write (16, *) 'particles lost in solenoid', ilost
      return
    end subroutine solnoid
    ! *******************************************************************
    ! SUBROUTINE elsol
    ! first order and second order R and T solenoid matrix
    ! *******************************************************************
    subroutine elsol
      implicit real *8(a-h, o-z)
      common /sole/l, kl, ko
      common /rigid/boro
      real *8 l, kl, ko
      common /bloc11/r(6, 6), t(6, 6, 6)
      common /secdr/iseor
      logical iseor
      ! PURE SOLENOID FIELD, MATRIX R AND T  ARE IN  (M,RD)
      ! SAVE KO AND L
      sako = ko
      sal = l
      ! convert (cm,rd) ==> (m,rd)
      ko = ko*100.
      l = l*1.e-02
      sn = sin(kl)
      cs = cos(kl)
      r(4, 4) = 0.5 + 0.5*cs
      r(3, 3) = r(4, 4)
      r(2, 2) = r(4, 4)
      r(1, 1) = r(4, 4)
      r(1, 4) = (1.-cs)/ko
      r(3, 2) = -r(1, 4)
      r(4, 1) = 0.25*ko*(1.-cs)
      r(2, 3) = -r(4, 1)
      r(4, 2) = -0.5*sn
      r(3, 1) = r(4, 2)
      r(2, 4) = -r(3, 1)
      r(1, 3) = r(2, 4)
      r(3, 4) = r(1, 3)*2./ko
      r(1, 2) = r(3, 4)
      r(4, 3) = -0.25*ko*sn
      r(2, 1) = r(4, 3)
      ! see element 16;  3.  in TRANSPORT USER MANUAL for SM (here: SM=0)
      ! omment       R(5,6) = R(5,6)  +  L * SM**2/(RI**2 + SM**2)
      if (.not. iseor) go to 200
      temp = 0.5*ko*l*sn
      t(1, 1, 6) = temp
      t(2, 2, 6) = temp
      t(3, 3, 6) = temp
      t(4, 4, 6) = temp
      t(1, 2, 6) = sn/ko - l*cs
      t(3, 4, 6) = t(1, 2, 6)
      temp = -0.5*ko*l*cs
      t(1, 3, 6) = temp
      t(2, 4, 6) = temp
      t(4, 2, 6) = -temp
      t(3, 1, 6) = -temp
      t(1, 4, 6) = (1.0-cs)/ko - l*sn
      t(3, 2, 6) = -t(1, 4, 6)
      t(2, 1, 6) = 0.25*ko*(ko*l*cs+sn)
      t(4, 3, 6) = t(2, 1, 6)
      t(2, 3, 6) = 0.25*ko*(1.0-cs+ko*l*sn)
      t(4, 1, 6) = -t(2, 3, 6)
      t(5, 2, 2) = 0.5*l
      t(5, 4, 4) = 0.5*l
200   continue
      ! RESTORE KO AND L
      ko = sako
      l = sal

      ! PATH LENGTH TERMS
      ! see element 16;  3.  in TRANSPORT USER MANUAL for SM here one takes: SM=0
      ! omment  T(5,6,6) = T(5,6,6) - L*(SM**2 + 1.5*RI**2)*SM**2/
      ! omment     1 (SM**2 + RI**2)**2
      ! omment  T(5,5,6) = SM**2/(SM**2 + RI**2)
      return
    end subroutine elsol
    ! *******************************************************************
    ! SUBROUTINE mfordre(rc,ra,rb)
    ! Calculates RC=RA*RB
    ! *******************************************************************
    subroutine mfordre(rc, ra, rb)
      implicit real *8(a-h, o-z)
      dimension ra(6, 6), rb(6, 6), rc(6, 6)

      do i1 = 1, 6
        do i2 = 1, 6
          ghost = 0.0
          do i3 = 1, 6
            ghost = ghost + ra(i1, i3)*rb(i3, i2)
          end do
          rc(i1, i2) = ghost
        end do
      end do
      return
    end subroutine mfordre
    ! *******************************************************************
    ! SUBROUTINE solquad(iksq,args,argq,xlsol,rg)
    ! SOLENOID FIELD ASSOCIATED WITH QUADRUPOLE FIELD
    ! space charge computations at the middle of the lens
    ! --IKSQ: IFLAG
    ! --ARGS: STRENGTH or FIELD OF SOLENOID
    ! If IKSQ = 0 then ARGS is the STRENGTH (cm-1), otherwise ARGS
    ! is the FIELD (kG)
    ! --ARGQ: STRENGTH or FIELD of QUADRUPOLE
    ! If IKSQ = 0 then ARGQ is the STRENGTH (cm-2), otherwise ARGQ
    ! is the FIELD (kG)
    ! SIGN CONVENTIONS:
    ! SOLENOID: ARGS positive = rotate the transverse coordinates
    ! about the z-axis in the clockwise direction.
    ! QUADRUPOLE: ARGQ positive = focusing in the plane (x,z)
    ! --XLSOL : EFFECTIVE LENGHT OF THE LENS(cm)
    ! --RG : APERTURE RADIUS OF THE LENS (cm)
    ! *******************************************************************
    subroutine solquad(iksq, args, argq, xlsol, rg)
      implicit real *8(a-h, o-z)
      parameter(iptsz=100002, maxcell=3000, maxcell1=3000)
      common /ttfc/tk, t1k, t2k, sk, s1k, s2k, fh
      common /fene/wdisp, wphas, wx, wy, rlim, ifw
      common /dyn/tref, vref
      common /rigid/boro
      common /dcspa/iesp
      common /faisc/f(10, iptsz), imax, ngood
      common /etcom/cog(8), exten(17), fd(iptsz)
      common /qmoyen/qmoy
      common /consta/vl, pi, xmat, rpel, qst
      common /tapes/in, ifile, meta
      common /pltprf/sprfx(3000), sprfy(3000), sprfl(3000), sprfw(3000), sprfp(3000), sprng(3000), iprf
      common /davcom/dav1(maxcell1, 40), davtot, iitem(maxcell1), idav
      common /shif/dtiph, shift
      common /rander/ialin
      common /femt/iemgrw, iemqesg
      common /cgtof/charm(20), cgtdv(20), nbch(20), netac
      common /compt/nrres, nrtre, nrbunc, nrdbun
      common /sc3/beamc, scdist, sce10, cplm, ect, apl, ichaes, iscsp
      logical ichaes
      logical iesp, shift, ialin, iemgrw
      character *1 cr
      common /slq/l, kso, kqo
      real *8 l, kso, kqo
      ! print out on terminal of transport element # on one and the same line
      nrtre = nrtre + 1
      cr = char(13)
      write (6, 8254) nrtre, nrres, cr
8254  format ('Transport element:', i5, '      Accelerating element:', i5, a1, $)
      fh0 = fh/vl
      ! PLOT
      if (iprf==1) call stapl(davtot*10.)
      ! random errors in alignment
      if (ialin) call randali
      ilost = 0
      ! magnetic rigidity (cog)
      gpa = 0.
      do ii = 1, ngood
        gpa = gpa + f(7, ii)/xmat
      end do
      gpa = gpa/float(ngood)
      l = xlsol
      bpa = sqrt(1.-1./(gpa*gpa))
      xmco = xmat*bpa*gpa
      ri = 33.356*xmco*1.e-01/qst
      if (iksq/=0) then
        ! argq: quadrupole field (kG), args:solenoid field:(kG)
        ! quadrupole
        fq = argq
        bq = fq/rg
        kqo = bq/ri
        strq = kqo
        ! solenoid (KSO = 2 * K, see ELSQ)
        bs = args
        kso = bs/ri
        strs = kso/2
      else
        ! argq: quadupole strength (cm-2), args: solenoid strength (cm-1)
        ! quadrupole
        kqo = argq
        strq = argq
        bq = argq*ri
        fq = bq*rg
        ! solenoid (KSO = 2 * K, see ELSQ)
        strs = args
        bs = 2.*strs*ri
        kso = bs/ri
      end if
      xks = kso/2.
      xksl = xks*l*57.29578
      write (16, *) '****SOLENOID+QUADRUPOLE*******'
      write (16, 101) xlsol, rg, bs, strs, xksl, fq, strq, ri
101   format ('  LENGTH =', f7.3, ' cm  APERTURE RADIUS=', e12.5, ' cm', /, '  SOLENOID: FIELD = ', f10.4, ' kG  K = ', &
        e12.5, ' cm-1  ROTATING ANGLE = ', e12.5, ' deg', /, '  QUADRUPOLE: FIELD  =', f10.4, ' kG   K2 =', e12.5, &
        ' cm-2 ', /, '  RIGIDITY = ', e12.5, ' kG.cm', /)
      ! print transport matrix (c.o.g.)
      ! For convenience, the matrix R and T are computed for a positive KQO = (B/r)*(1/BRO)
      ! if KQO is negative one has seting up 90 degree rotation on the beam
      call elsq
      write (16, *) ' The matrix R and T are shown for a positive strength'
      write (16, *) ' For a negative strength set up 90 deg rotation on the beam'
      call matrix
      ! start prints in file 'short.data'
      idav = idav + 1
      iitem(idav) = 11
      dav1(idav, 1) = xlsol*10.
      dav1(idav, 2) = bs
      dav1(idav, 3) = fq
      dav1(idav, 5) = strq
      dav1(idav, 6) = kso/2.
      dav1(idav, 7) = rg*10.
      dav1(idav, 8) = ri
      davtot = davtot + xlsol
      dav1(idav, 4) = davtot*10.
      ! first half lens
      dg = xlsol
      l = xlsol/2.
      do ii = 1, ngood
        call clear
        gpai = f(7, ii)/xmat
        bpai = sqrt(1.-1./(gpai*gpai))
        xmco = xmat*bpai*gpai
        ri = 33.356*xmco*1.e-01/f(9, ii)
        ! KSO =K/2, see ELSQ
        kso = bs/ri
        if (kso==6.*0) kso = 1.e-16
        kqo = bq/ri
        call elsq
        ! the matrix R and T are computed for a positive KQO = (B/rg)*(1/BRO)
        ! if KQO is negative set up 90 degree rotation on the beam
        if (kqo<6.*0) then
          irot = ii
          call rotat(irot)
          call cobeam(ii, l)
          ! return the coordinates to their initial orientation
          irot = -ii
          call rotat(irot)
        else
          call cobeam(ii, l)
        end if
      end do
      ! Charge space effect (if l >0)
      if (ichaes .and. l>0.) then
        if (sce10==1 .or. sce10==3.) then
          iesp = .true.
          write (16, *) 'space charge at the middle  '
          call cesp(xlsol)
          iesp = .false.
          ! Change the dispersion dE/E with respect to the C.O.G of the bunch
          call disp
        end if
      end if
      ! test window after the first half solquad
      call cogetc
      bcour = 0.
      do i = 1, ngood
        gpai = f(7, i)/xmat
        bcour = sqrt(1.-1./(gpai*gpai)) + bcour
      end do
      bcour = bcour/float(ngood)
      gcour = 1./sqrt(1.-bcour*bcour)
      wcg = (gcour-1.)*xmat
      ! ----- convert wdisp in dp/p (for window control)
      tref = tref + xlsol/(2.*vref)
      call reject(ilost)
      ! Reshuffles f(i,j) array after window (now done in 'reject')
      ! call shuffle
      ! beam after the second half lens
      do ii = 1, ngood
        call clear
        gpai = f(7, ii)/xmat
        bpai = sqrt(1.-1./(gpai*gpai))
        xmco = xmat*bpai*gpai
        ri = 33.356*xmco*1.e-01/f(9, ii)
        kso = bs/ri
        ! KSO =K/2, see ELSQ
        if (kso==0.) kso = 1.e-16
        kqo = bq/ri
        call elsq
        ! the matrix R and T are computed for a positive KQO = (B/r)*(1/BRO)
        ! if KQO is negative set up 90 degree rotation on the beam
        if (kqo<6.*0) then
          irot = ii
          call rotat(irot)
          call cobeam(ii, l)
          irot = -ii
          call rotat(irot)
        else
          call cobeam(ii, l)
        end if
      end do
      ! t.o.f of reference
      tref = tref + xlsol/(vref*2.)
      call reject(ilost)
      dav1(idav, 36) = ngood
      ! plots
      call stapl(davtot*10.)
      if (iemgrw) call emiprt(0)
      write (16, *) 'particles lost in solenoid', ilost
      return
    end subroutine solquad
    ! *******************************************************************
    ! SUBROUTINE rotat(ii)
    ! (+-) 90 DEG BEAM ROTATION
    ! *******************************************************************
    subroutine rotat(ii)
      implicit real *8(a-h, o-z)
      parameter(iptsz=100002, maxcell=3000, maxcell1=3000)
      common /faisc/f(10, iptsz), imax, ngood
      dimension ff(6)

      if (ii>=0) then
        ! 90 degree rotation
        ff(1) = f(2, ii)
        ff(2) = f(3, ii)
        ff(3) = f(4, ii)
        ff(4) = f(5, ii)
        f(2, ii) = ff(3)
        f(3, ii) = ff(4)
        f(4, ii) = -ff(1)
        f(5, ii) = -ff(2)
      else
        ! -90 degree rotation
        ii = -ii
        ff(1) = f(2, ii)
        ff(2) = f(3, ii)
        ff(3) = f(4, ii)
        ff(4) = f(5, ii)
        f(2, ii) = -ff(3)
        f(3, ii) = -ff(4)
        f(4, ii) = ff(1)
        f(5, ii) = ff(2)
      end if
      return
    end subroutine rotat
    ! *******************************************************************
    ! SUBROUTINE elsq
    ! FIRST AND SECOND order MATRIX R AND T  (m,rd)
    ! quadrupole field combined with a solenoid field
    ! **** WARNING : IN THIS ROUTINE ALL VARIABLES ARE REAL UNLESS
    ! OTHERWIZE DECLARED *********
    ! *******************************************************************
    subroutine elsq
      implicit real *8(a-z)
      common /rigid/boro
      common /slq/l, kso, kqo
      common /bloc11/r(6, 6), t(6, 6, 6)
      common /secdr/iseor
      logical iseor

      al = l*1.e-02
      akq = kqo*1.e04
      aks = kso*1.e02
      aks = aks/2.
      akq4 = akq*akq
      aks2 = aks*aks
      aks3 = aks2*aks
      aks4 = aks2*aks2
      q2 = dsqrt(akq4+4.0*aks4)
      q2i = 1.0/q2
      sk1 = sqrt(2.0*aks2+q2)
      sk3 = sqrt(abs(q2-2.0*aks2))
      ss = sin(sk1*al)
      sc = cos(sk1*al)
      bs = sinh(sk3*al)
      bc = cosh(sk3*al)
      skp = 0.5*(sk1+sk3)
      skm = 0.5*(sk1-sk3)
      skp2 = skp*skp
      skp3 = skp2*skp
      skm2 = skm*skm
      skm3 = skm2*skm
      r(1, 1) = q2i*(skp2*sc+skm2*bc)
      r(1, 2) = q2i*(skp*ss-skm*bs)
      r(1, 3) = q2i*aks*(skm*ss+skp*bs)
      r(1, 4) = q2i*aks*(bc-sc)
      r(2, 1) = q2i*(-skp3*ss-skm3*bs)
      r(2, 2) = q2i*(skp2*sc+skm2*bc)
      r(2, 3) = q2i*aks3*(sc-bc)
      r(2, 4) = q2i*aks*(skp*ss-skm*bs)
      r(3, 1) = q2i*aks*(skm*bs-skp*ss)
      r(3, 2) = q2i*aks*(sc-bc)
      r(3, 3) = q2i*(skm2*sc+skp2*bc)
      r(3, 4) = q2i*(skm*ss+skp*bs)
      r(4, 1) = q2i*aks3*(bc-sc)
      r(4, 2) = q2i*aks*(-skm*ss-skp*bs)
      r(4, 3) = q2i*(skp3*bs-skm3*ss)
      r(4, 4) = q2i*(skm2*sc+skp2*bc)
      if (.not. iseor) return
      daks = -aks
      dakq = -akq
      dakq4 = 2.0*akq*dakq
      daks2 = 2.0*aks*daks
      daks3 = 3.0*aks2*daks
      daks4 = 4.0*aks3*daks
      dq2 = 0.5*q2i*(dakq4+4.0*daks4)
      q2i2 = q2i*q2i
      dq2i = -q2i2*dq2
      dsk1 = (2.0*daks2+dq2)/(2.0*sk1)
      dsk3 = 0.0
      if (sk3/=6.*0) dsk3 = (dq2-2.0*daks2)/(2.0*sk3)
      dss = sc*dsk1*al
      dsc = -ss*dsk1*al
      dbs = bc*dsk3*al
      dbc = bs*dsk3*al
      dskp = 0.5*(dsk1+dsk3)
      dskm = 0.5*(dsk1-dsk3)
      dskp2 = 2.0*skp*dskp
      dskp3 = 3.0*skp2*dskp
      dskm2 = 2.0*skm*dskm
      dskm3 = 3.0*skm2*dskm
      t(1, 1, 6) = dq2i*(skp2*sc+skm2*bc) + q2i*(dskp2*sc+skp2*dsc+dskm2*bc+skm2*dbc)
      t(1, 2, 6) = dq2i*(skp*ss-skm*bs) + q2i*(dskp*ss+skp*dss-dskm*bs-skm*dbs)
      t(1, 3, 6) = (dq2i*aks+q2i*daks)*(skm*ss+skp*bs) + q2i*aks*(dskm*ss+skm*dss+dskp*bs+skp*dbs)
      t(1, 4, 6) = (dq2i*aks+q2i*daks)*(bc-sc) + q2i*aks*(dbc-dsc)
      t(2, 1, 6) = dq2i*(-skp3*ss-skm3*bs) + q2i*(-dskp3*ss-skp3*dss-dskm3*bs-skm3*dbs)
      t(2, 2, 6) = t(1, 1, 6)
      t(2, 3, 6) = (dq2i*aks3+q2i*daks3)*(sc-bc) + q2i*aks3*(dsc-dbc)
      t(2, 4, 6) = (dq2i*aks+q2i*daks)*(skp*ss-skm*bs) + q2i*aks*(dskp*ss+skp*dss-dskm*bs-skm*dbs)
      t(3, 1, 6) = -t(2, 4, 6)
      t(3, 2, 6) = -t(1, 4, 6)
      t(3, 3, 6) = dq2i*(skm2*sc+skp2*bc) + q2i*(dskm2*sc+skm2*dsc+dskp2*bc+skp2*dbc)
      t(3, 4, 6) = dq2i*(skm*ss+skp*bs) + q2i*(dskm*ss+skm*dss+dskp*bs+skp*dbs)
      t(4, 1, 6) = -t(2, 3, 6)
      ! omment      AMAT(17,4,MATADR)=-AMAT(21,1,MATADR)
      t(4, 2, 6) = -t(1, 3, 6)
      t(4, 3, 6) = dq2i*(skp3*bs-skm3*ss) + q2i*(dskp3*bs+skp3*dbs-dskm3*ss-skm3*dss)
      t(4, 4, 6) = t(3, 3, 6)
      aisssc = 0.0
      if (sk1/=0.0) aisssc = ss*ss/(2.0*sk1)
      aibsbc = 0.0
      if (sk3/=0.0) aibsbc = bs*bs/(2.0*sk3)
      aissbc = q2i*(sk3*ss*bs-sk1*sc*bc+sk1)
      aiscbs = q2i*(sk3*sc*bc+sk1*ss*bs-sk3)
      aiss2 = 0.0
      aisc2 = al
      aibs2 = 0.0
      aibc2 = al
      if (sk1/=0.0) aiss2 = 0.5*(al-ss*sc/sk1)
      if (sk1/=0.0) aisc2 = 0.5*(al+ss*sc/sk1)
      if (sk3/=0.0) aibs2 = 0.5*(bs*bc/sk3-al)
      if (sk3/=0.0) aibc2 = 0.5*(al+bs*bc/sk3)
      aissbs = q2i*(sk3*ss*bc-sk1*sc*bs)
      aiscbc = q2i*(sk1*ss*bc+sk3*sc*bs)
      aks5 = aks4*aks
      aks6 = aks5*aks
      skp4 = skp3*skp
      skp5 = skp4*skp
      skp6 = skp5*skp
      skm4 = skm3*skm
      skm5 = skm4*skm
      skm6 = skm5*skm
      q4i = q2i*q2i
      t(5, 1, 1) = q4i*0.5*(skp6*aiss2+skm6*aibs2-2.0*skp3*skm3*aissbs+aks6*(aisc2+aibc2-2.0*aiscbc))
      t(5, 1, 2) = q4i*(-skp5*aisssc-skp3*skm2*aissbc-skm3*skp2*aiscbs-skm5*aibsbc-aks4*(-skm*aisssc-skp*aiscbs+skm* &
        aissbc+skp*aibsbc))
      t(5, 1, 3) = q4i*aks3*((skp3-skm3)*(aissbc-aisssc)+(skp3+skm3)*(aibsbc-aiscbs))
      t(5, 1, 4) = q4i*(aks*(-skp4*aiss2-(skp3*skm+skm3*skp)*aissbs+skm4*aibs2)+aks3*(-skm2*aisc2-(skp2-skm2)*aiscbc+ &
        skp2*aibc2))
      t(5, 2, 2) = q4i*0.5*(skp4*aisc2+2.0*skp2*skm2*aiscbc+skm4*aibc2+aks2*(skm2*aiss2+2.0*skp*skm*aissbs+skp2*aibs2))
      t(5, 2, 3) = q4i*(aks3*(skp2*aisc2-(skp2-skm2)*aiscbc-skm2*aibc2)-aks*(-skm4*aiss2+(skm*skp3- &
        skp*skm3)*aissbs+skp4*aibs2))
      t(5, 2, 4) = q4i*aks*((skp3-skm3)*aisssc-(skp2*skm+skp*skm2)*aiscbs+(skm2*skp-skm*skp2)*aissbc-(skm3+skp3)*aibsbc)
      t(5, 3, 3) = q4i*0.5*(aks6*(aisc2-2.0*aiscbc+aibc2)+skm6*aiss2-2.0*skm3*skp3*aissbs+skp6*aibs2)
      t(5, 3, 4) = q4i*(aks4*(skp*aisssc-skm*aiscbs-skp*aissbc+skm*aibsbc)-skm5*aisssc-skm3*skp2*aissbc+skp3*skm2*aiscbs &
        +skp5*aibsbc)
      t(5, 4, 4) = q4i*0.5*(aks2*(skp2*aiss2-2.0*skp*skm*aissbs+skm2*aibs2)+skm4*aisc2+2.0*skm2*skp2*aiscbc+skp4*aibc2)
      return
    end subroutine elsq
    ! *******************************************************************
    ! SUBROUTINE fdrift(xl,npart,imit)
    ! DIVIDE A DRIFT LENGHT OF :XL CM  IN :NPART PARTIAL DRIFTS
    ! This will allow several space charge computations in the drift
    ! *******************************************************************
    subroutine fdrift(xl, npart, imit)
      implicit real *8(a-h, o-z)

      dl = xl/float(npart)
      do i = 1, npart
        call drift(dl)
        if (imit/=0.) call emiprt(0)
      end do
      return
    end subroutine fdrift
    ! *******************************************************************
    ! SUBROUTINE drift(dl)
    ! DRIFT LENGHT
    ! space charge computation at the middle of the drift
    ! *******************************************************************
    subroutine drift(dl)
      implicit real *8(a-h, o-z)
      parameter(iptsz=100002, maxcell=3000, maxcell1=3000)
      common /rigid/boro
      common /consta/vl, pi, xmat, rpel, qst
      common /dyn/tref, vref
      common /ttfc/tk, t1k, t2k, sk, s1k, s2k, fh
      common /faisc/f(10, iptsz), imax, ngood
      common /tapes/in, ifile, meta
      common /davcom/dav1(maxcell1, 40), davtot, iitem(maxcell1), idav
      common /etcom/cog(8), exten(17), fd(iptsz)
      common /sc3/beamc, scdist, sce10, cplm, ect, apl, ichaes, iscsp
      common /fene/wdisp, wphas, wx, wy, rlim, ifw
      common /dcspa/iesp
      common /pltprf/sprfx(3000), sprfy(3000), sprfl(3000), sprfw(3000), sprfp(3000), sprng(3000), iprf
      common /shif/dtiph, shift
      common /femt/iemgrw, iemqesg
      common /posc/xpsc
      common /cgtof/charm(20), cgtdv(20), nbch(20), netac
      common /tofev/ttvols
      common /itvole/itvol, imamin
      logical iesp, ichaes, shift, iemgrw, itvol, imamin

      ilost = 0
      fh0 = fh/vl
      fcpi = fh*180./pi
      write (16, *) '*** DRIFT of length ', dl, ' cm'
      if (itvol) write (16, 10) ttvols*fcpi, davtot
10    format (' ** tof for adjustments at input: ', e12.5, ' deg at position: ', e12.5, ' cm in the lattice')
      ! STATISTICS
      if (iprf==1) call stapl(davtot*10.)
      ! random error in position only if dl is positif
      ! Beam at the half drift
      dg2 = dl/2.
      do i = 1, ngood
        ! conversion mrad ===> rad
        f2 = f(3, i)*.001
        f4 = f(5, i)*.001
        f(2, i) = f(2, i) + dg2*tan(f2)
        f(4, i) = f(4, i) + dg2*tan(f4)/cos(f2)
        gpai = f(7, i)/xmat
        bpai = sqrt(1.-1./(gpai*gpai))
        vpai = vl*bpai
        f(6, i) = f(6, i) + dg2/(vpai*cos(f2)*cos(f4))
      end do
      ! ENVEL
      ! start prints in file 'short.data'
      davtot = davtot + dl
      if (dl>0.) then
        ! nlength=nlength+1
        idav = idav + 1
        iitem(idav) = 7
        dav1(idav, 1) = dl*10.
        dav1(idav, 4) = davtot*10.
      end if
      ! Charge space  (if dl >1.e-04)
      if (ichaes .and. dl>=1.e-04) then
        if (sce10==3.) then
          iesp = .true.
          write (16, *) ' space charge at the middle'
          call cesp(dl)
          iesp = .false.
          ! Change the dispersion dE/E with respect to the C.O.G of the bunch
          call disp
        end if
      end if
      ! Test window after the first half drift
      tref = tref + dl/(vref*2.)
      call reject(ilost)
      ! Reshuffles f(i,j) array after window (now done in 'reject')
      ! call shuffle
      il = ilost
      ! Beam for the second half drift
      do i = 1, ngood
        f2 = f(3, i)*.001
        f4 = f(5, i)*.001
        f(2, i) = f(2, i) + dg2*tan(f2)
        f(4, i) = f(4, i) + dg2*tan(f4)/cos(f2)
        gpai = f(7, i)/xmat
        bpai = sqrt(1.-1./(gpai*gpai))
        vpai = vl*bpai
        f(6, i) = f(6, i) + dg2/(vpai*cos(f2)*cos(f4))
      end do
      ! Test window after the second half drift (only in transverse directions and phase)
      tref = tref + dl/(vref*2.)
      call reject(ilost)
      il = il + ilost
      ! change the reference and the TOF
      if (itvol) ttvols = tref
      if (dl>0.) then
        dav1(idav, 36) = ngood
        ! envelope
        call stapl(davtot*10.)
      end if
      tcog = 0.
      do i = 1, ngood
        tcog = tcog + f(6, i)
      end do
      tcog = tcog/float(ngood)
      if (itvol) then
        write (16, 11) ttvols*fcpi, davtot, tref*fcpi, tcog*fcpi
11      format (' ** tof for adjustments : ', e12.5, ' deg at position: ', e12.5, ' cm in the lattice', /, 3x, &
          'tof of the reference: ', e12.5, ' deg tof of the cog: ', e12.5, ' deg')
      else
        write (16, 12) tref*fcpi, tcog*fcpi
12      format (' ** tof of the reference: ', e12.5, ' deg tof of the cog: ', e12.5, ' deg')
      end if
      write (16, *) 'particles lost in drift: ', il
      if (iemgrw .and. dl>0.) then
        if (iemqesg==2) call emiprt(0)
      end if
      return
    end subroutine drift
    subroutine clear
      ! CLEAR MATRIX R AND T
      implicit real *8(a-h, o-z)
      common /bloc11/r(6, 6), t(6, 6, 6)
      common /secdr/iseor
      logical iseor
      ! CLEAR R
      do ia = 1, 6
        do ib = 1, 6
          r(ia, ib) = 0.
          if (ia==ib) r(ia, ib) = 1.
        end do
      end do
      ! CLEAR T
      if (iseor) then
        do ia = 1, 6
          do ib = 1, 6
            do ic = 1, 6
              t(ia, ib, ic) = 0.
            end do
          end do
        end do
      end if
      return
    end subroutine clear
    ! *******************************************************************
    ! SUBROUTINE cobeam(ii,xl)
    ! MATRIX BASED BEAM COMPUTATION
    ! *******************************************************************
    subroutine cobeam(ii, xl)
      implicit real *8(a-h, o-z)
      parameter(iptsz=100002, maxcell=3000, maxcell1=3000)
      common /faisc/f(10, iptsz), imax, ngood
      common /bloc11/r(6, 6), t(6, 6, 6)
      common /etcom/cog(8), exten(17), fd(iptsz)
      common /consta/vl, pi, xmat, rpel, qst
      common /radia/trt, rmoy, xintf, crae
      common /secdr/iseor
      logical iseor
      dimension sf(6), ssf(6)
      ! MATRIX R AND T ARE IN  M-RD
      ! beam conversion:  CM ===> M      MRD ==> RD
      sf(1) = f(2, ii)*1.e-02
      sf(2) = f(3, ii)*1.e-03
      sf(3) = f(4, ii)*1.e-02
      sf(4) = f(5, ii)*1.e-03
      sf(5) = xl*1.e-02
      sf(5) = sf(5)/(cos(sf(2))*cos(sf(4)))
      sf(6) = (fd(ii)-1.)
      ! FIRST order COMPUTATION (M-RD)
      do ia = 1, 6
        ssf(ia) = 0.
        do ib = 1, 6
          ssf(ia) = r(ia, ib)*sf(ib) + ssf(ia)
        end do
      end do
      if (.not. iseor) go to 10
      ! SECOND order COMPUTATION  (M-RD)
      do ia = 1, 6
        do ib = 1, 6
          do ic = 1, 6
            ssf(ia) = ssf(ia) + t(ia, ib, ic)*sf(ib)*sf(ic)
          end do
        end do
      end do
10    continue
      do ia = 1, 4
        f(ia+1, ii) = ssf(ia)
      end do
      ! CONVERT RD ==> MRD    M ==> CM
      f(3, ii) = f(3, ii)*1000.
      f(5, ii) = f(5, ii)*1000.
      f(2, ii) = f(2, ii)*100.
      f(4, ii) = f(4, ii)*100.
      gpai = f(7, ii)/xmat
      bpai = sqrt(1.-1./(gpai*gpai))
      vpai = vl*bpai
      trt = 100.*ssf(5)/vpai
      f(6, ii) = f(6, ii) + trt
      return
    end subroutine cobeam
    ! *******************************************************************
    ! SUBROUTINE disp
    ! Compute the dispersion dE/E with respect to the center of
    ! gravity of the bunch
    ! *******************************************************************
    subroutine disp
      implicit real *8(a-h, o-z)
      parameter(iptsz=100002, maxcell=3000, maxcell1=3000)
      common /faisc/f(10, iptsz), imax, ngood
      common /etcom/cog(8), exten(17), fd(iptsz)
      common /mcs/imcs, ncstat, cstat(20)
      common /consta/vl, pi, xmat, rpel, qst

      gcog = 0.
      do i = 1, ngood
        gcog = f(7, i)/xmat + gcog
      end do
      gcog = gcog/float(ngood)
      bcog = sqrt(1.-1./(gcog*gcog))
      do i = 1, ngood
        gpai = f(7, i)/xmat
        if (gpai>=1.) then
          bpai = sqrt(1.-1./(gpai*gpai))
        else
          bpai = 0.
        end if
        fd(i) = bpai/bcog*gpai/gcog
      end do
      return
    end subroutine disp
    ! old    do ist=1,ncstat
    ! old         gcog=0.
    ! old         nii=0
    ! old         do ii=1,ngood
    ! old          if(f(9,ii).eq.cstat(ist)) then
    ! old            gcog=gcog+f(7,ii)/xmat
    ! old            nii=nii+1
    ! old           endif
    ! old          enddo
    ! old           gcog=gcog/float(nii)
    ! old           bcog=sqrt(1.-1./(gcog*gcog))
    ! old          DO II=1,NGOOD
    ! old           if(f(9,ii).eq.cstat(ist)) then
    ! old            gpai=f(7,ii)/xmat
    ! old            bpai=sqrt(1.-1./(gpai*gpai))
    ! old            fd(ii)=(gpai*bpai)/(gcog*bcog)
    ! old           endif
    ! old          enddo
    ! old         enddo
    ! old        return
    ! old        end
    ! *******************************************************************
    ! SUBROUTINE zrotat(zrot)
    ! BEAM ROTATION
    ! the transverse coordinates X and Y may be rotated
    ! through an angle about the axis tangent to the
    ! central trajectory at the point in question.
    ! *******************************************************************
    subroutine zrotat(zrot)
      implicit real *8(a-h, o-z)
      parameter(iptsz=100002, maxcell=3000, maxcell1=3000)
      common /faisc/f(10, iptsz), imax, ngood
      common /grot/rzot, izrot
      common /consta/vl, pi, xmat, rpel, qst
      common /davcom/dav1(maxcell1, 40), davtot, iitem(maxcell1), idav
      logical izrot
      dimension rs(6, 6), ff(6), fc(6)

      write (16, 100) zrot
100   format (/, 20x, 'BEAM ROTATION ', f10.4, '  degrees  ABOUT THE POSITIVE Z-AXIS', /)
      if (.not. izrot) then
        izrot = .true.
        rzot = zrot
        go to 500
      end if
      if (izrot) izrot = .false.
500   continue
      ! Daves start
      idav = idav + 1
      iitem(idav) = 20
      dav1(idav, 1) = zrot
      ! initialize
      do ia = 1, 4
        do ib = 1, 4
          rs(ia, ib) = 0.
        end do
      end do
      ! Conversion DEG ==> RAD
      zrot = zrot*pi/180.
      rs44 = cos(zrot)
      rs(4, 4) = rs44
      rs(3, 3) = rs44
      rs(2, 2) = rs44
      rs(1, 1) = rs44
      rs24 = sin(zrot)
      rs(2, 4) = rs24
      rs(1, 3) = rs24
      rs(4, 2) = -rs24
      rs(3, 1) = -rs24
      do ii = 1, ngood
        ff(1) = f(2, ii)
        ff(2) = f(3, ii)
        ff(3) = f(4, ii)
        ff(4) = f(5, ii)
        do ia = 1, 4
          fc(ia) = 0.
          do ib = 1, 4
            fc(ia) = fc(ia) + ff(ib)*rs(ia, ib)
          end do
        end do
        f(2, ii) = fc(1)
        f(3, ii) = fc(2)
        f(4, ii) = fc(3)
        f(5, ii) = fc(4)
      end do
      ! 110    continue
      return
    end subroutine zrotat
    ! *******************************************************************
    ! SUBROUTINE zrotap(zrot)
    ! BEAM ROTATION
    ! the transverse coordinates X and Y may be rotated
    ! through an angle about the axis tangent to the
    ! central trajectory at the point in question.
    ! *******************************************************************
    subroutine zrotap(zrot)
      implicit real *8(a-h, o-z)
      parameter(iptsz=100002, maxcell=3000, maxcell1=3000)
      common /faisc/f(10, iptsz), imax, ngood
      common /grot/rzot, izrot
      common /consta/vl, pi, xmat, rpel, qst
      logical izrot
      dimension rs(6, 6), ff(6), fc(6)

      write (16, 100) zrot
100   format (/, 20x, 'BEAM ROTATION ', f10.4, '  degrees  ABOUT THE POSITIVE Z-AXIS', /)
      rzot = zrot
      ! Conversion DEG ==> RAD
      zrot = zrot*pi/180.
      rs44 = cos(zrot)
      rs(4, 4) = rs44
      rs(3, 3) = rs44
      rs(2, 2) = rs44
      rs(1, 1) = rs44
      rs24 = sin(zrot)
      rs(2, 4) = rs24
      rs(1, 3) = rs24
      rs(4, 2) = -rs24
      rs(3, 1) = -rs24
      do ii = 1, ngood
        ff(1) = f(2, ii)
        ff(2) = f(3, ii)
        ff(3) = f(4, ii)
        ff(4) = f(5, ii)
        do ia = 1, 4
          fc(ia) = 0.
          do ib = 1, 4
            fc(ia) = fc(ia) + ff(ib)*rs(ia, ib)
          end do
        end do
        f(2, ii) = fc(1)
        f(3, ii) = fc(2)
        f(4, ii) = fc(3)
        f(5, ii) = fc(4)
      end do
      return
    end subroutine zrotap
    ! *******************************************************************
    ! SUBROUTINE aliner
    ! ALIGNMENT  errors:
    ! HORIZONTAL : XL(cm) XLP(mrad)
    ! VERTICAL   : YL(cm) YLP(mrad)
    ! *******************************************************************
    subroutine aliner
      implicit real *8(a-h, o-z)
      parameter(iptsz=100002, maxcell=3000, maxcell1=3000)
      common /alin/xl, yl, xpl, ypl
      common /faisc/f(10, iptsz), imax, ngood

      write (16, 100) xl, yl, xpl, ypl
100   format (/, 5x, ' KICK x(cm)    y(cm)   : ', 2(e12.5,2x), /, 5x, ' KICK xp(mrad) yp(mrad): ', 2(e12.5,2x), //)
      ! CALCUL DES COORDONNEES DES TRAJECTOIRES
      ! UNITES  =  CM-MRD
      do ii = 1, ngood
        f(2, ii) = f(2, ii) + xl
        f(4, ii) = f(4, ii) + yl
        f(3, ii) = f(3, ii) + xpl
        f(5, ii) = f(5, ii) + ypl
      end do
      return
    end subroutine aliner
    ! *******************************************************************
    ! SUBROUTINE randali
    ! RANDOM ALIGNMENT  errors :
    ! HORIZONTAL PLANE : XL(cm) XLP(mrad)
    ! VERTICAL PLANE   : YL(cm) YLP(mrad)
    ! *******************************************************************
    subroutine randali
      implicit real *8(a-h, o-z)
      parameter(iptsz=100002, maxcell=3000, maxcell1=3000)
      common /alin/xl, yl, xpl, ypl
      common /faisc/f(10, iptsz), imax, ngood
      common /apel/iapel
      dimension trans(1)

      write (16, *) ' random error in alignment with:'
      write (16, 100) xl, yl, xpl, ypl
100   format (/, 5x, ' KICK x(cm)    y(cm)   : ', 2(e12.5,2x), /, 5x, ' KICK xp(mrad) yp(mrad): ', 2(e12.5,2x), //)
      len = 1
      rdcf = .5
      call rlux(trans, len)
      if (trans(1)<=rdcf) sign = -1.
      if (trans(1)>rdcf) sign = 1.
      call rlux(trans, len)
      xla = xl*sign*trans(1)
      call rlux(trans, len)
      if (trans(1)<=rdcf) sign = -1.
      if (trans(1)>rdcf) sign = 1.
      call rlux(trans, len)
      yla = yl*sign*trans(1)
      call rlux(trans, len)
      if (trans(1)<=rdcf) sign = -1.
      if (trans(1)>rdcf) sign = 1.
      call rlux(trans, len)
      xpla = xpl*sign*trans(1)
      call rlux(trans, len)
      if (trans(1)<=rdcf) sign = -1.
      if (trans(1)>rdcf) sign = 1.
      call rlux(trans, len)
      ypla = ypl*sign*trans(1)
      write (16, 100) xla, yla, xpla, ypla
      do ii = 1, ngood
        f(2, ii) = f(2, ii) + xla
        f(4, ii) = f(4, ii) + yla
        f(3, ii) = f(3, ii) + xpla
        f(5, ii) = f(5, ii) + ypla
      end do
      return
    end subroutine randali
    ! *******************************************************************
    ! SUBROUTINE matrix
    ! print first and second order matrix of a lens
    ! *******************************************************************
    subroutine matrix
      implicit real *8(a-h, o-z)
      common /bloc11/r(6, 6), t(6, 6, 6)
      common /secdr/iseor
      logical iseor

      write (16, *) ' TRANSPORT MATRIX (m-rd)'
      write (16, *) ' FIRST ORDER TRANSPORT********'
      do ia = 1, 6
        write (16, 100)(r(ia,ib), ib=1, 6)
      end do
100   format (6(3x,e12.5))
      write (16, *) ' *************************************************'
      if (iseor) then
        write (16, *) ' SECOND ORDER TRANSPORT (m-rd)********'
        do ia = 1, 6
          do ib = 1, 6
            do ic = 1, 6
              if (t(ia,ib,ic)/=6.*0) write (16, 101) ia, ib, ic, t(ia, ib, ic)
            end do
          end do
        end do
        write (16, *) ' *************************************************'
      end if
101   format (' T', 3(i1), 3x, e12.5)
      return
    end subroutine matrix
    ! *******************************************************************
    ! SUBROUTINE egun(fmult,indp)
    ! method:Bode's rule
    ! read the axial field of the DC gun field from disk
    ! z (m)   E(z) is normalized
    ! *******************************************************************
    subroutine egun(fmult, indp)
      implicit real *8(a-h, o-z)
      parameter(iptsz=100002, maxcell=3000, maxcell1=3000)
      common /ttfc/tk, t1k, t2k, sk, s1k, s2k, fh
      common /faisc/f(10, iptsz), imax, ngood
      common /consta/vl, pi, xmat, rpel, qst
      common /azlist/icont, iprin
      common /dyn/tref, vref
      common /rigid/boro
      common /etcom/cog(8), exten(17), fd(iptsz)
      common /qmoyen/qmoy
      common /tapes/in, ifile, meta
      common /pltprf/sprfx(3000), sprfy(3000), sprfl(3000), sprfw(3000), sprfp(3000), sprng(3000), iprf
      common /davcom/dav1(maxcell1, 40), davtot, iitem(maxcell1), idav
      common /femt/iemgrw, iemqesg
      common /cgtof/charm(20), cgtdv(20), nbch(20), netac
      common /compt/nrres, nrtre, nrbunc, nrdbun
      common /sc3/beamc, scdist, sce10, cplm, ect, apl, ichaes, iscsp
      common /dcspa/iesp
      common /spl/xspl(4000), yspl(4000), s(5000), p(5000), q(5000)
      dimension gam(3000), xe(3000), xpe(3000), ye(3000), ype(3000)
      character *1 cr
      logical flgsc, iesp, ichaes, iemgrw
      ! print out on terminal of transport element # on one and the same line
      nrres = nrres + 1
      cr = char(13)
      write (6, 8254) nrtre, nrres
8254  format ('Transport element:', i5, '      Accelerating element:', i5)
      write (6, *) 'EGUN calculation started'
      ! energy at the entrance
      we = 0.
      do i = 1, ngood
        we = we + f(7, i)
      end do
      we = we/float(ngood) - xmat
      ! indp: define the number of space charge computations
      ! indp = 1 : 8 space charge computations. The EGUN field is divided in 16 elements
      ! indp = 2 : 16 space charge computation.                           in 32 elements
      ! indp = 3 : 32 space charge computation.                           in 64 elements
      if (indp>3) indp = 3
      if (indp==1) ipart = 16
      if (indp>=2) ipart = 32
      if (indp==3) ipart = 64
      ! research the number of steps w.r.t. the input energy
      ! convert energy: MeV --> eV
      we = we*1.e06
      weinf = 19.99
      if (we<=weinf) then
        write (6, *) ' Energy at the cathode: ', we, ' eV is below the lower limit of 20 eV '
        stop
      end if
      ! read egun field on the disk
      e0 = xmat
      vlm = vl*1.e-02
      read (22, *) npt
      do i = 1, npt
        read (22, *) xspl(i), yspl(i)
      end do
      zinf = xspl(1)
      zsup = xspl(npt)
      egl = zsup - zinf
      call deriv2(npt)
      elgun = egl*100.
      ! PLOT
      if (iprf==1) call stapl(davtot*10.)
      ! start prints in file 'short.data'
      idav = idav + 1
      idavs = idav
      iitem(idav) = 13
      dav1(idav, 1) = egl*1000.
      dav1(idav, 2) = fmult
      davtot = davtot + elgun
      dav1(idav, 4) = elgun*10.
      ! divide the length in ipart partitions
      ! the space charge computations are made at the middle of each partition
      eglp = egl/float(ipart)
      ! eglsc :space charge acting lenght (cm)  (of each part)
      scl = float(ipart)/2.
      eglsc = egl*100./scl
      ! compute the EGUN field (MV)
      npas = 200
      xpas = eglp/float(npas)
      xnhf = 0
      dcfld = 0.
      do i = 1, npas
        fpos = xnhf*xpas
        tspl = spline(npt, fpos)*fmult
        dcfld = dcfld + qst*tspl*xpas
        xnhf = xnhf + 1.
      end do
      ! 4443   format(2x,i5,3(2x,e12.5))
      dav1(idav, 3) = dcfld*1000.
      write (16, 101) elgun, fmult, dcfld*1000.
101   format (5x, ' FIELD LENGTH =', f7.3, ' CM ', /, 5x, '  FIELD CREST=', f10.4, ' MV/m', /5x, '  FIELD STENGTH= ', &
        e12.5, ' kV', /)
      ! omment       write(49,5557)
      ! omment5557   format(6x,'z(m)',14x,'x(m)',14x,'xp(rad)',11x,'y(m)',14x,
      ! omment     *        'yp(rad)',11x,'energy(MeV)')
      ! **** demarrage sur 0.5 mm (?) soit 0.5 e-03 m
      ! thresold of energy
      swe1 = 19.99
      swe2 = 79.99
      npas = 200
      if (we<swe1) npas = 400
      if (we<swe2) npas = 300
      xlstart = 0.5e-03
      xpas = xlstart/float(npas)
      npas1 = npas + 1
      iflg = -1
      xnht = 0.
      flgsc = .false.
501   continue
      if (iflg==ipart) go to 500
      do j = 1, ngood
        xnh = xnht
        qc = f(9, j)
        gam0 = f(7, j)/e0
        gam(1) = gam0
        tof = f(6, j)
        ! the tranverse coordinates are converted in (m,rad)
        x0 = f(2, j)*1.e-02
        y0 = f(4, j)*1.e-02
        t0 = f(3, j)*1.e-03
        p0 = f(5, j)*1.e-03
        ! Pitch transformation
        xe0 = x0*(gam0*gam0-1.)**0.25
        xpe0 = t0*(gam0*gam0-1.)**0.25
        ye0 = y0*(gam0*gam0-1.)**0.25
        ype0 = p0*(gam0*gam0-1.)**0.25
        fpos = xnh*xpas
        tspl = spline(npt, fpos)*fmult
        dgam = (qc/e0)*tspl
        dgami = dgam
        xpe0 = xpe0 + .5*xe0*gam0*dgam/(gam0*gam0-1)
        ype0 = ype0 + .5*ye0*gam0*dgam/(gam0*gam0-1)
        a1 = qc*qc/(4.*e0*e0)
        a2 = qc/(e0*vlm)
        xe(1) = xe0
        xpe(1) = xpe0
        ye(1) = ye0
        ype(1) = ype0
        do i = 2, npas1
          i1 = i - 1
          fpos1 = xnh*xpas
          fpos2 = (xnh+0.25)*xpas
          fpos3 = (xnh+0.5)*xpas
          fpos4 = (xnh+0.75)*xpas
          fpos5 = (xnh+1.)*xpas
          tspl1 = spline(npt, fpos1)*fmult
          tspl2 = spline(npt, fpos2)*fmult
          tspl3 = spline(npt, fpos3)*fmult
          tspl4 = spline(npt, fpos4)*fmult
          tspl5 = spline(npt, fpos5)*fmult
          cw = (qc/e0)*xpas/90.
          tspl = 7.*tspl1 + 32.*tspl2 + 12.*tspl3 + 32.*tspl4 + 7.*tspl5
          gam(i) = cw*tspl + gam(i1)
          gam1 = gam(i1)
          gam5 = gam(i)
          dgam1 = (qc/e0)*tspl1
          cof1 = (gam5-gam1)/(xpas*xpas)
          cof2 = dgam1/xpas
          cof = cof1 - cof2
          gam2 = gam1 + dgam1*xpas/4. + cof*xpas*xpas/16.
          gam3 = gam1 + dgam1*xpas*0.5 + cof*xpas*xpas/4.
          gam4 = gam1 + dgam1*xpas*0.75 + cof*9.*xpas*xpas/16.
          gams1 = gam1*gam1
          gams2 = gam2*gam2
          gams3 = gam3*gam3
          gams4 = gam4*gam4
          gams5 = gam5*gam5
          ! omment          bgt1=(gams1-1.)**1.5
          bgt2 = (gams2-1.)**1.5
          bgt3 = (gams3-1.)**1.5
          bgt4 = (gams4-1.)**1.5
          bgt5 = (gams5-1.)**1.5
          tslpt = 8.*tspl2/bgt2 + 6.*tspl3/bgt3 + 24.*tspl4/bgt4 + 7.*tspl5/bgt5
          dt = a2*xpas*xpas*tslpt/90.
          bet = sqrt(1.-1./gams1)
          tof = tof + xpas/(vlm*bet) + dt
          f(7, j) = gam(i)*e0
          f(6, j) = tof
          bg1 = (gams1+2.)/((gams1-1.)*(gams1-1.))
          bg2 = (gams2+2.)/((gams2-1.)*(gams2-1.))
          bg3 = (gams3+2.)/((gams3-1.)*(gams3-1.))
          bg4 = (gams4+2.)/((gams4-1.)*(gams4-1.))
          bg5 = (gams5+2.)/((gams5-1.)*(gams5-1.))
          bgts1 = bg1*tspl1*tspl1
          bgts2 = bg2*tspl2*tspl2
          bgts3 = bg3*tspl3*tspl3
          bgts4 = bg4*tspl4*tspl4
          bgts5 = bg5*tspl5*tspl5
          ! gtpm=bgts1+3.*bgts2+3.*bgts3+bgts4
          gtpm = 7.*bgts1 + 32.*bgts2 + 12.*bgts3 + 32.*bgts4 + 7.*bgts5
          ! gtm=bgts1+2.*bgts2+bgts3
          gtm = 7.*bgts1 + 24.*bgts2 + 6.*bgts3 + 8.*bgts4
          ! gtpz=bgts2+2.*bgts3+bgts4
          gtpz = 8.*bgts2 + 6.*bgts3 + 24.*bgts4 + 7.*bgts5
          gtm1 = 2.*bgts2 + 3.*bgts3 + 18.*bgts4 + 7.*bgts5
          de = -a1*xpas*xpas*gtm/90.
          de1 = -a1*xpas*xpas*xpas*gtm1/90.
          dpe1 = -a1*xpas*gtpm/90.
          dpe2 = -a1*xpas*xpas*gtpz/90.
          dxpe1 = dpe1*xe(i1)
          dype1 = dpe1*ye(i1)
          dxpe2 = dpe2*xpe(i1)
          dype2 = dpe2*ype(i1)
          dxe = de*xe(i1) + de1*xpe(i1)
          dye = de*ye(i1) + de1*ype(i1)
          xpe(i) = xpe(i1) + dxpe1 + dxpe2
          ype(i) = ype(i1) + dype1 + dype2
          xe(i) = xe(i1) + dxe + xpe(i1)*xpas
          ye(i) = ye(i1) + dye + ype(i1)*xpas
          ! back to the real variables and convert to (cm,mrad)
          gamm1 = (gams5-1.)**0.25
          gamm2 = (gams5-1.)**1.25
          dgam = (qc/e0)*tspl5
          xi = xe(i)/gamm1
          xpi = xpe(i)/gamm1 - xe(i)*gam(i)*dgam/(gamm2*2.)
          yi = ye(i)/gamm1
          ypi = ype(i)/gamm1 - ye(i)*gam(i)*dgam/(gamm2*2.)
          ! convert in cm and mrd
          f(2, j) = xi*1.e02
          f(4, j) = yi*1.e02
          f(3, j) = xpi*1.e03
          f(5, j) = ypi*1.e03
          ! *****  follow prtcl ifpt  not active ************
          ! omment          if(j.eq.ifpt)
          ! omment     *    write(49,4445) fpos5,xi,xpi,yi,ypi,e0*(gam5-1.)
          ! omment4445      format(6(2x,e12.5))
          xnh = xnh + 1.
        end do
      end do
      iflg = iflg + 1
      xnht = xnh
      if (iflg==0) then
        if (indp==1) npas = 96
        if (indp==2) npas = 48
        if (indp==3) npas = 24
        npas1 = npas + 1
        xlres = egl - xlstart
        xpas = xlres/(float(npas)*float(ipart))
        xnht = fpos5/xpas
        flgsc = .true.
        dav1(idavs, 7) = tspl5
        dav1(idav, 5) = xlstart*1000.
        call disp
        go to 501
      end if
      if (iflg==1) then
        if (indp==1) npas = 48
        if (indp==2) npas = 24
        if (indp==3) npas = 12
        npas1 = npas + 1
        xlres = egl - xlstart
        xpas = xlres/(float(npas)*float(ipart))
        xnht = fpos5/xpas
      end if
      if (.not. flgsc) then
        flgsc = .true.
        call disp
        go to 501
      end if
      if (flgsc) then
        if (ichaes) then
          ! Charge space
          iesp = .true.
          call cesp(eglsc)
          iesp = .false.
          ! Change the dispersion dE/E with respect to the C.O.G of the bunch
        end if
        call disp
        flgsc = .false.
        ! reference ( c.o.g. of the bunch)
        tref = 0.
        gref = 0.
        do ij = 1, ngood
          tref = tref + f(6, ij)
          gref = gref + f(7, ij)/e0
        end do
        tref = tref/float(ngood)
        gref = gref/float(ngood)
        bets = sqrt(1.-1./(gref*gref))
        vref = bets*vl
        ! omment    call emiprt(0)
        write (16, 562) fpos5*1000, tref, bets, tspl5
        write (6, 1562) fpos5*1000, bets, cr
562     format (' ref.(c.o.g.) at ', e12.5, ' mm of the  cathode', /, 5x, ' tof: ', e12.5, ' sec beta: ', e12.5, &
          ' field (MV/m) ', e12.5)
1562    format (' EGUN: at ', e12.5, ' mm from the cathode; beta: ', e12.5, a1, $)
        go to 501
      end if
500   continue
      write (6, *)
      write (6, *) 'EGUN calculation finished'
      ! reference ( c.o.g. of the bunch)
      tref = 0.
      gref = 0.
      do i = 1, ngood
        tref = tref + f(6, i)
        gref = gref + f(7, i)/e0
      end do
      tref = tref/float(ngood)
      gref = gref/float(ngood)
      bets = sqrt(1.-1./(gref*gref))
      write (16, 561) tref, bets
561   format (' ref. at output of the DC gun', /, 5x, ' tof: ', e12.5, ' sec beta: ', e12.5)
      vref = bets*vl
      ! new magnetic rigidity of the reference
      xmor = xmat*bets*gref
      boro = 33.356*xmor*1.e-01/qst
      dav1(idavs, 6) = bets
      dav1(idavs, 36) = ngood
      ! plots
      call stapl(davtot*10.)
      call emiprt(0)
      return
    end subroutine egun
    ! *******************************************************************
    ! SUBROUTINE scheff1_swesson(int)
    ! 21-Apr-2014: This routine is NOT used by DYNAC
    ! comment       SUBROUTINE scheff1(int)
    ! non relativistic SCHEFF space charge method
    ! SCE(i) (for ISCSP=3 only)
    ! int=0: initiate the arrays
    ! SCE(1)=BEAMC (as above)
    ! SCE(2)=r extension in rms multiples
    ! SCE(3)=z extension in rms multiples
    ! SCE(4)=no. of radial mesh intervals (le 20)
    ! SCE(5)=no. of longitudinal mesh intervals (le 40)
    ! SCE(6)=no. of adjacent bunches, applicable for buncher studies
    ! and should be 0 for linac dynamics
    ! SCE(7)=pulse length, if not beta lambda.(transport studies)
    ! distance bewteen beam pulses input zero to get default
    ! "beta lambda"; units are cm
    ! SCE(8)=determines frequency of calculating mesh size. see pard
    ! SCE(9)=option to integrate space charge forces over box
    ! if.eq.0. no integration.  see sub gaus for further
    ! explanation.
    ! SCE(10)=same meaning as SCE10 above
    ! *******************************************************************
    subroutine scheff1_swesson(int)
      implicit real *8(a-h, o-z)
      parameter(iptsz=100002, maxcell=3000, maxcell1=3000)
      common /dyn/tref, vref
      common /cmpte/iell
      common /part/xc(iptsz), yc(iptsz), zc(iptsz)
      common /dimens/zcp(iptsz), xcp(iptsz), ycp(iptsz)
      common /hermt/afxt(22), afyt(22), afzt(22)
      common /ttfc/tk, t1k, t2k, sk, s1k, s2k, fh
      common /consta/vl, pi, xmat, rpel, qst
      common /sc3/beamc, scdist, sce10, cplm, ect, apl, ichaes, iscsp
      common /faisc/f(10, iptsz), imax, ngood
      common /cdek/dwp(iptsz)
      common /beamsa/fs(7, iptsz)
      common /dcspa/iesp
      common /compt/nrres, nrtre, nrbunc, nrdbun
      common /posc/xpsc
      logical ichaes, iesp
      common /bg/bsc, gsc, phis, wsync
      ! named common bg, contains beta and gamma as determined in pardyn.
      ! they may be values at beginning of cell, end of cell, or mid-way.
      common /fldcom/rp, zp, pl, opt, nip
      common /spacech1/rm(21), zm(41), rs(20), ers(16800), ezs(16800), ez(861), aa(800), rssq(20), zzs(41), er(861), &
        rss(20), ismax(40), iemax(41)
      common /rcshef/sce(20)
      ! set up field tables
      if (int==0) then
        beami = beamc/1000.0
        wavel = 2.*pi*vl/fh
        freq = fh/(2.*pi)
        btazro = vref/vl
        frrms = sce(2)
        fzrms = sce(3)
        nr = idint(sce(4))
        nz = idint(sce(5))
        nip = idint(sce(6))
        opt = sce(9)
        ! omment        if(ncell.gt.0) pl=cell(4,ncell)
        if (sce(7)>0.) pl = sce(7)
        pl = btazro*wavel
        nr1 = nr + 1
        nz1 = nz + 1
        im1 = nr*nz
        im2 = nr1*nz1
        im3 = nr1*nz
        na = 1
        nb = ngood
        nq = nb - na + 1
        return
      end if
      beami = beamc/1000.0
      if (beami==0. .or. scdist==0.) return
      iell = iell + 1
      write (16, *) ' *call SCHEFF  ', iell
      call pintim
      call sizrms(0, xrms, yrms, zrms, zz)
      write (16, 6875) xrms, yrms, zrms
      ! write the size rms in the output file 17
      ! omment       write(17,25) iell,xrms,yrms,zrms
      ! omment25     format(2x,i5,3(2x,e12.5))
6875  format (' RMS size(m)', e12.5, 2x, e12.5, 2x, e12.5)
      rrms = sqrt(xrms*xrms+yrms*yrms)
      ! change unit: m==>cm
      zrms1 = zrms*100.
      rrms = rrms*100.
      dr = rrms*frrms/float(nr)
      dz = zrms1*fzrms/float(nz)
      rmax = float(nr)*dr
      ! load rm, zm, rs, zs
      rm(1) = 0.0
      do i = 2, nr1
        rm(i) = float(i-1)*dr
        rssq(i-1) = .5*(rm(i-1)**2+rm(i)**2)
        rss(i-1) = 0.5*(rm(i-1)+rm(i))
        rs(i-1) = sqrt(rssq(i-1))
      end do
      zs = .5*dz
      do i = 1, nz1
        zm(i) = float(i-1)*dz
        zzs(i) = zm(i) + zs
      end do
      hl = float(nz)*zs
      ! load ers and ezs
      ! mesh dimensions are in cm. ers and ezs are in 1/cm.
      ! c1, c2 and c3 are in cm., and c4 is in mev-cm.
      ! q=coulombs/point.   (2/pi)*e/(4*pi*epsilon)=572167 cm mev/coul.
      q = beami/(freq*float(nq))
      c1 = 572167.*q/xmat
      l = 0
      do k = 1, nr
        rfac = (rm(k+1)**2-rm(k)**2)*dz/2.
        if (opt==0.) rfac = 1.
        do j = 1, nz
          zp = zm(j+1)
          do i = 1, nr1
            rp = rm(i)
            if (opt==0.) call flds(rs(k), zs, er1, ez1)
            if (opt==0.) go to 35
            call gaus(rm(k), rm(k+1), zm(1), zm(2), opt, er1, ez1)
35          l = l + 1
            ers(l) = c1*er1/rfac
            ezs(l) = c1*ez1/rfac
          end do
        end do
      end do
      if (beamc==0. .or. scdist==0.) return
      dz1 = scdist/100.
      dist = scdist
      write (16, *) ' fields acting length(cm): ', dist
      ! evaluate and apply space charge effects.
      ! phimc=phi of mesh center.
      ! Shifts particle coordinates to a single point in time. Uses
      ! a linear shift
      ! Beam c.g.
      xbar = 0.
      ybar = 0.
      zbar = 0.
      brmoy = 0.
      trmoy = 0.
      do np = 1, ngood
        gpai = f(7, np)/xmat
        brmoy = brmoy + sqrt(1.-1./(gpai*gpai))
        trmoy = trmoy + f(6, np)
      end do
      trmoy = trmoy/float(ngood)
      phimc = trmoy*fh
      pbar = phimc
      beta = brmoy/float(ngood)
      gsc = 1./sqrt(1.-beta*beta)
      bg = beta*gsc
      c2 = beta*wavel/(2.*pi)
      gmsq = 1. + bg**2
      c3 = dist/(bg*beta*gmsq)
      c4 = dist*xmat
      gam = sqrt(gmsq)
      c5 = 1./(gam*(gam+1.))
      ! evaluate ng, xbar, ybar
      ng = 0
      xbar = 0.
      ybar = 0.
      xsq = 0.
      ysq = 0.
      do np = 1, ngood
        ng = ng + 1
        x = f(2, np)
        y = f(4, np)
        xbar = xbar + x
        ybar = ybar + y
        xsq = xsq + x**2
        ysq = ysq + y**2
      end do
      eng = float(ngood)
      xbar = xbar/eng
      ybar = ybar/eng
      ! the mesh center is phi*syn
      xsq = xsq/eng
      ysq = ysq/eng
      epsq = sqrt((xsq-xbar*xbar)/(ysq-ybar*ybar))
      epsqi = 1./epsq
      xfac = 2./(epsq+1.)
      yfac = epsq*xfac
      ! clear and load bins
      ng = 0
      do i = 1, im1
        aa(i) = 0.0
      end do
      do np = 1, ngood
        rsq = (f(2,np)-xbar)**2*epsqi + (f(4,np)-ybar)**2*epsq
        ! i=sqrt(rsq)/dr+1.
        r = sqrt(rsq)
        halfdr = dr*0.5
        i = idint(r/dr+1.0)
        if (i>nr) go to 120
        zph = f(6, np)*fh
        z = -c2*(zph-phimc)
        if (abs(z)>=hl) go to 120
        ! ------distribute charge among adjacent bins.
        ng = ng + 1
        zz = z + hl
        jm1 = idint(zz/dz+1.)
        i1 = i + 1
        ! if (rsq.lt.rssq(i)) i1=i-1
        if (rsq<rss(i)) i1 = i - 1
        if (i1<1) i1 = 1
        if (i1>nr) i1 = nr
        j1 = jm1 + 1
        if (zz<zzs(jm1)) j1 = jm1 - 1
        if (j1<1) j1 = 1
        if (j1>nz) j1 = nz
        a = 1.
        ! if (i1.ne.i) a=(rsq-rssq(i1))/(rssq(i)-rssq(i1))
        if (r>halfdr) then
          rminsq = (r-halfdr)**2
          rmaxsq = (r+halfdr)**2
          if (i1<i) then
            a = (rmaxsq-rm(i)**2)/(rmaxsq-rminsq)
          else
            a = (rm(i1)**2-rminsq)/(rmaxsq-rminsq)
          end if
        end if
        b = 1. - a
        cc = 1.
        if (j1/=jm1) cc = (zz-zzs(j1))/(zzs(jm1)-zzs(j1))
        d = 1. - cc
        k = (jm1-1)*nr + i
        aa(k) = aa(k) + a*cc
        k = k + i1 - i
        aa(k) = aa(k) + b*cc
        k = (j1-1)*nr + i
        aa(k) = aa(k) + a*d
        k = k + i1 - i
        aa(k) = aa(k) + b*d
120   end do
      eng = ng
      ! find ismax for each j
      do j = 1, nz
        l = (j-1)*nr
        k = nr
        do i = 1, nr
          m = l + k
          if (aa(m)<=0.00) then
            k = k - 1
            go to 130
          else
            go to 140
          end if
130       continue
        end do
140     ismax(j) = k
      end do
      ! find iemax for each j
      iemax(1) = 1 + ismax(1)
      do j = 2, nz
        iemax(j) = 1 + max0(ismax(j-1), ismax(j))
      end do
      iemax(nz1) = 1 + ismax(nz)
      ! set er and ez to zero
      do i = 1, im2
        er(i) = 0.0
        ez(i) = 0.0
      end do
      ! sum up fields
      do js = 1, nz
        js1 = js + 1
        ism = ismax(js)
        if (ism==0) go to 220
        do is = 1, ism
          l = (js-1)*nr + is
          a1 = aa(l)
          if (a1==0.) go to 210
          l = (is-1)*im3
          do je = 1, js
            k1 = l + (js-je)*nr1
            n1 = (je-1)*nr1
            iem = iemax(je)
            if (iem<=1) go to 180
            do ie = 1, iem
              n = n1 + ie
              k = k1 + ie
              er(n) = er(n) + a1*ers(k)
              ez(n) = ez(n) - a1*ezs(k)
            end do
180       end do
          do je = js1, nz1
            k1 = l + (je-js1)*nr1
            n1 = (je-1)*nr1
            iem = iemax(je)
            if (iem<=1) go to 200
            do ie = 1, iem
              n = n1 + ie
              k = k1 + ie
              er(n) = er(n) + a1*ers(k)
              ez(n) = ez(n) + a1*ezs(k)
            end do
200       end do
210     end do
220   end do
      ! evaluate and apply impulse
      rrmax = 0.
      zzmax = 0.
      zzmin = 1000.
      npz = 0
      npr = 0
      do np = 1, ngood
        r = sqrt((f(2,np)-xbar)**2*epsqi+(f(4,np)-ybar)**2*epsq)
        zph = f(6, np)*fh
        z = -c2*(zph-phimc)
        if (z>=zzmax) zzmax = z
        if (z<zzmin) zzmin = z
        if (r>=rrmax) rrmax = r
        if (r==0.) r = .000001
        xor = (f(2,np)-xbar)*xfac/r
        yor = (f(4,np)-ybar)*yfac/r
        if (r>rmax) then
          npr = npr + 1
          go to 230
        end if
        ! zph=f(6,np)*fh
        ! z=-c2*(zph-phimc)
        ! if(z.ge.zzmax) zzmax=z
        ! if(z.lt.zzmin) zzmin=z
        if (abs(z)>hl) then
          npz = npz + 1
          go to 230
        end if
        ! interpolate impulse within mesh.
        rb = r/dr
        i = idint(1.0+rb)
        a = rb - float(i-1)
        b = 1.0 - a
        zb = (z+hl)/dz
        j = idint(1.0+zb)
        c = zb - float(j-1)
        d = 1.0 - c
        l = i + (j-1)*nr1
        m = l + nr1
        crp = c3*(d*(a*er(l+1)+b*er(l))+c*(a*er(m+1)+b*er(m)))
        cen = c4*(d*(a*ez(l+1)+b*ez(l))+c*(a*ez(m+1)+b*ez(m)))
        crp = crp*abs(f(9,np))
        cen = cen*abs(f(9,np))
        go to 260
        ! estimate impulse based on point charge at xbar,ybar,pbar.
230     continue
        d = sqrt(z**2+r**2)
        rod3 = r/d**3
        zod3 = z/d**3
        if (nip==0) go to 250
        ! include neighboring bunches.
        do i = 1, nip
          xi = i
          do j = 1, 2
            s = z + xi*pl
            d = sqrt(s**2+r**2)
            rod3 = rod3 + r/d**3
            zod3 = zod3 + s/d**3
            xi = -xi
          end do
        end do
        ! evaluate impulse.
250     continue
        crp = eng*c1*c3*rod3*pi/2.
        cen = eng*c1*c4*zod3*pi/2.
        crp = crp*abs(f(9,np))
        cen = cen*abs(f(9,np))
        ! apply impulse
260     continue
        ! convert from mrad to rad
        f3 = f(3, np)*1.e-03
        f5 = f(5, np)*1.e-03
        dwc = f(7, np) - xmat
        dxp = crp*xor - f3*cen*c5/dwc
        dyp = crp*yor - f5*cen*c5/dwc
        if (.not. iesp) then
          ! load the entrance beam parameters for cavities or gaps
          do js = 1, 7
            f(js, np) = fs(js, np)
          end do
          f(3, np) = f(3, np) + dxp*1000.
          f(5, np) = f(5, np) + dyp*1000.
          f(2, np) = f(2, np) - dz1*dxp*100.*xpsc
          f(4, np) = f(4, np) - dz1*dyp*100.*xpsc
          dwp(np) = cen
        else
          f(3, np) = f(3, np) + dxp*1000.
          f(5, np) = f(5, np) + dyp*1000.
          f(7, np) = f(7, np) + cen
        end if
      end do
      return
    end subroutine scheff1_swesson
    ! *******************************************************************
    ! SUBROUTINE cpardyn(pib)
    ! --- make up a list of cell by cell RFQ data based on a file
    ! generated by the external code

    ! nc: cell number
    ! ityp = 0: Standard accelerating cell
    ! ityp = 1: Transition cell of type T
    ! ityp = 2: Transition cell of type E
    ! ityp = 3: Transition cell of type M
    ! ityp = 4: Fringe-field region from the potential function
    ! (after type T, M or accelerating cell)
    ! ityp = 5: Radial matching section based on coefficients
    ! ityp = 6: Radial matching section based on RMS shape defined in
    ! an external file
    ! ityp = 7: Fringe-field region; the profile is defined in an
    ! external file (after type T, M or accelerating cell)
    ! a(1): cell length (cm)
    ! a(2): coefficient A10 (no dimension)
    ! a(3): smallest aperture  a  of vanes (cm)
    ! a(4): modulation factor  m  (no dimension)
    ! a(5): mean aperture ( r0 ) of vanes (middle of cells)   (cm)
    ! a(6): transverse radius of curvature (rh0) of the surface of
    ! electrodes at the vane tip (cm)
    ! a(7): phase (deg) (at the entrance of cells)
    ! a(8): factor FVOLT to be applied at the intervane potential
    ! (only for particles)
    ! VOLT =  (1 + FVOLT )* (intervane voltage)
    ! a(9): intervane-voltage (KV)

    ! ipar: cell parity (like for PARMTEQ cells)
    ! --- Note: the last line in file must be:
    ! 0  0  0. 0. 0. 0. 0. 0. 0. 0. 0. 0
    ! *******************************************************************
    subroutine cpardyn(pib)
      implicit real *8(a-h, o-z)
      common /consta/vl, pi, xmat, rpel, qst
      common /rf1ptq/tvolt, avolt, fph, mlc, nceltot
      common /rf2ptq/rfq1(500), rfq2(500), rfq3(500), rfq4(500), rfq6(500), rfq7(500), rfq8(500), rfq9(500)
      common /rf5ptq/tdvolt, rfq10(500), rfq11(500)
      common /rfq3ptq/itype(500), ipari(500), evens, evenr
      common /ttfc/tk, t1k, t2k, sk, s1k, s2k, fh
      common /dyn/tref, vref
      common /bonda/cbx(500), bbx(500), ablx(500), cby(500), bby(500), ably(500)
      common /spl/xspl(4000), yspl(4000), s(5000), p(5000), q(5000)
      common /spff/xspf(400), yspf(400), sf(500), pf(500), qf(500)
      common /rms_prfl/npt, npf
      dimension a(16), vptq(16)
      character *80 vprof, fprof
      logical even, evens, evenr
      ! Do so by shifting particles belonging to the same bunch outside the (+/-) pib/2 (rad) window
      ! w.r.t.the REF to inside the (+/-) pib/2 window w.r.t.the COG
      if (abs(pib)>6.*0.) then
        pib = pi
        call accep_rfq(pib)
      end if
      erest = xmat
      ! --- for simulating PARMTEQ cells, odd cells have A01 positive and even cells have A01 negative
      ! ---  even: logical flag, even = true ==> A01 is positive, otherwise A01 is negative
      even = .true.
      netc = 0
50    continue
      ! --- read the data of the RFQ from the input file
      ! ****************************************************************
      ! ---   read 11 parameters from unit 27), file 'myfile', in the form:
      ! nc  ityp intervane-voltage (KV) cl(cm)  A10  a(cm)  m  r0(cm) rho(cm) phase(deg) fvolt ipar
      netc = netc + 1
      read (27, *) nc, ityp, (vptq(j), j=1, 9), ipar
      if (ityp==6) then
        ! if the RMS is of type 6, get the filename of the RMS descriptor
        read (27, '(A80)') vprof
        write (16, *) 'Read RMS from file ', vprof
      end if
      if (ityp==7) then
        ! if the Fringe Field is of type 7, get the filename of the FF descriptor
        read (27, '(A80)') fprof
        write (16, *) 'Read Fringe Field from file ', fprof
      end if
      a(1) = vptq(2)
      a(2) = vptq(3)
      a(3) = vptq(4)
      a(4) = vptq(5)
      a(5) = vptq(6)
      a(6) = vptq(7)
      a(7) = vptq(8)
      a(8) = vptq(9)
      a(9) = vptq(1)
      ! **************************************************
      ! convert intervane voltage in MV
      a(9) = a(9)*1.e-03
      if (nc==1) tdvolt = a(9)
      ! ----  stop at the last line with nc = 0
      if (nc==0) go to 60
      if (nc>nceltot) go to 60
      itype(nc) = ityp
      ipari(nc) = ipar
      if (itype(nc)==5) then
        ! Radial matching section from potential function
        ! ---------------------------------------------------------------------------------------------
        ! Note: The total length L(rms) of the RMS must be the sum of the RMS-cell lengths in the
        ! Parmteq file. rho is equal to the distance between the axis and the vane, r0, at the
        ! exit of the RMS
        ! we have used the approximation of the modified Bessel functions for small arguments
        ! and we have negleted the terms of higher order in r greater than 2
        ! ----------------------------------------------------------------------------------------------
        write (16, *) 'RFQ RMS from potential function'
        cl = a(1)
        r0 = a(5)
        rh0 = a(6)
        phim = a(7)
        fact = 1. + a(8)
        xk = pi/(2.*cl)
        xq0 = 1./6.*xk*xk*rh0*rh0
        ! old sv         aq=9./(8.*xq0)
        aq = 1./xq0
        ! ---   limits x-vane y-vane
        cbx(nc) = 1.5*r0*1.e-02
        cby(nc) = 1.5*r0*1.e-02
        ablx(nc) = 0.
        ably(nc) = 0.
        bbx(nc) = 0.
        bby(nc) = 0.
        ! ---  convert all parameters in units (MeV, m)
        ! rfq1(nc): Aq (no dimension)
        ! rfq2(nc): not used
        ! rfq3(nc): RMS length (m)
        ! rfq4(nc): phase RF (deg)
        ! rfq7(nc): mean aperture of the vane r0 (m)
        ! rfq9(nc): factor to be applied at the inter-vane potentiel (only for particles)
        ! rfq10(nc):intervane voltage applied to the synchronous particle (kV)
        ! rfq11(nc):intervane voltage applied to the particles (kV)

        rfq1(nc) = aq
        rfq2(nc) = 0.
        rfq3(nc) = cl*1.e-02
        rfq4(nc) = phim
        rfq7(nc) = r0*1.e-02
        rfq9(nc) = fact
        rfq10(nc) = (1.+tvolt)*a(9)
        rfq11(nc) = (1.+avolt)*a(9)
        go to 50
      end if
      if (itype(nc)==6) then
        ! read from disk the RMS profile in the form (z,R(z)), with z,R in meter
        ! npt is the number of (z,R(z)) coordinates
        open (67, file=vprof, status='unknown')
        ! read(67,*)npt
        npt = 0
        do
          read (67, *, end=777) xspl(npt+1), yspl(npt+1)
          npt = npt + 1
        end do
777     write (16, *) 'RFQ RMS from file with ', npt, ' data points'
        call deriv2(npt)
        ! cl; length of the RMS (in M)
        cl = xspl(npt)
        r0 = yspl(npt)
        phim = a(7)
        fact = 1. + a(8)
        ! ---   limits x-vane y-vane
        cbx(nc) = 1.5*r0
        cby(nc) = 1.5*r0
        ablx(nc) = 0.
        ably(nc) = 0.
        bbx(nc) = 0.
        bby(nc) = 0.
        ! rfq1(nc) : not used
        ! rfq2(nc): not used
        ! rfq3(nc): RMS length (m)
        ! rfq4(nc): phase RF (deg)
        ! rfq7(nc): distance axe-vanes at the end of the RMS (m)
        ! rfq9(nc): factor to be applied at the inter-vane potentiel (only for particles)
        ! rfq10(nc):intervane voltage applied to the synchronous particle (kV)
        ! rfq11(nc):intervane voltage applied to the particles (kV)
        ! rfq1(nc)=0.
        rfq2(nc) = 0.
        rfq3(nc) = cl
        rfq4(nc) = phim
        rfq7(nc) = r0
        rfq9(nc) = fact
        rfq10(nc) = (1.+tvolt)*a(9)
        rfq11(nc) = (1.+avolt)*a(9)
        close (67)
        ! cc        write(16,579)nc,npt,cl,phim,r0,rfq10(nc),rfq11(nc)
        ! cc579     format(2(2x,i4),5(2x,e12.5))
        go to 50
      end if
      ! End Radial matching section
      ! --- Standard accelerationg cell
      if (itype(nc)==0) then
        cl = a(1)
        a10 = a(2)
        xa = a(3)
        xm = a(4)
        r0 = a(5)
        rh0 = a(6)
        ! fph : factor affecting the phase at entrance of cells (only available for type = 0)
        a(7) = fph*a(7)
        phim = a(7)
        fact = 1. + a(8)
        ! coefficient A01 (1/(cm*cm))
        alpha = rh0/r0
        a01 = 3.*(1.+5.*alpha)/(2.*r0*r0*(1.+7.*alpha))
        ! coefficient A03: (1/(cm**6) )
        a03 = -(1.+alpha)/(2.*r0**6*(1.+7.*alpha))
        ! coefficient A12: no dimensions
        xam = xa*xm
        a12 = 0.
        xk1 = 1. - a01*xa*xa - a03*(xa**6)
        yk2 = -1. + a01*xam*xam + a03*(xam**6)
        ! Bessel functions: I0(ka) I0(mka) I4(ka) I4(mka)
        xk = pi/cl
        za0 = xk*xa
        zam = za0*xm
        no = 0
        bi0 = bint(no, za0)
        ! old        bi0=1.+za0*za0/4.+za0**4/64.+za0**6/2304.+za0**8/1.47456e05
        ! old        bi0=bi0+za0**10/1.47456e07
        bim = bint(no, zam)
        ! old        bim=1.+zam*zam/4.+zam**4/64.+zam**6/2304.+zam**8/1.47456e05
        ! old        bim=bim+zam**10/1.47456e07
        no = 4
        bi4 = bint(no, za0)
        ! old        bi4=(za0/2.)**4/24.
        ! old        zaa0=za0*za0/4.
        ! old        bi4=bi4+(za0/2.)**4*zaa0/120.
        ! old        bi4=bi4+(za0/2.)**4*zaa0*zaa0/1440.
        bim4 = bint(no, zam)
        ! old        zamm=zam*zam/4.
        ! old        bim4=(zam/2.)**4/24.
        ! old        bim4=bim4+(zam/2.)**4*zamm/120.
        ! old        bim4=bim4+(zam/2.)**4*zamm*zamm/1440.
        den1 = bim4*bi0 - bim*bi4
        if (abs(den1)>1.e-09) a12 = (yk2*bi0-xk1*bim)/den1
        ! ********************************************************************************************
        ! NOTE: the coefficient A10 is read in the file 'myfile' but it also can be computed in Dynac
        ! from multipolar expansions (see the two following fortran lines):
        ! cc        a10=0.
        ! cc        if(abs(den1).gt.1.e-09) a10=(xk1*bim4-yk2*bi4)/den1
        ! ************************************
        ! or from first order computations (see the two following lines):
        ! cc        dencc=xm*xm*bi0+bim
        ! cc        a10=(xm*xm-1.)/dencc
        ! ********************************************************************************************
        ! ---  convert all parameters in units (MeV, m)
        ! rfq1(nc): A01 ( 1/(m*m) )
        ! rfq2(nc): A10 (no dimension)
        ! rfq3(nc): cell length (m)
        ! rfq4(nc): phase RF (deg)
        ! rfq6(nc): A12 (no dimension)
        ! rfq7(nc): mean aperture of the vane r0 (m)
        ! rfq8(nc): A03 (1/(m**6)
        ! rfq9(nc): error factor F = 1 + a(8)
        ! rfq10(nc):intervane voltage applied to the synchronous particle (KV)
        ! rfq11(nc):intervane voltage applied to the particles (KV)
        ! ---  odds cells have a01 positive, even cells have a01 negative

        rfq1(nc) = a01*1.e04
        ! ---  limits x-vane y-vane
        ncf = (ipari(nc)/2)*2 - ipari(nc)
        if (ncf/=0) then
          ! odd number standard cell limits
          cbx(nc) = xa
          bbx(nc) = (4.*r0-xm*xa-3.*cbx(nc))/cl
          ablx(nc) = xa*xm/(cl*cl) - bbx(nc)/cl - cbx(nc)/(cl*cl)
          cby(nc) = xa*xm
          bby(nc) = (4.*r0-xa-3.*cby(nc))/cl
          ably(nc) = xa/(cl*cl) - bby(nc)/cl - cby(nc)/(cl*cl)
        else
          ! even number standard cell limits
          cbx(nc) = xm*xa
          bbx(nc) = (4.*r0-xa-3.*cbx(nc))/cl
          ablx(nc) = xa/(cl*cl) - bbx(nc)/cl - cbx(nc)/(cl*cl)
          cby(nc) = xa
          bby(nc) = (4.*r0-xm*xa-3.*cby(nc))/cl
          ably(nc) = xm*xa/(cl*cl) - bby(nc)/cl - cby(nc)/(cl*cl)
        end if
        ! 8526  continue
        ! conversion: cm --> m
        cbx(nc) = cbx(nc)*1.e-02
        ablx(nc) = ablx(nc)*1.e02
        cby(nc) = cby(nc)*1.e-02
        ably(nc) = ably(nc)*1.e02
        ! end limits ******************************
        rfq2(nc) = a10
        rfq3(nc) = cl*1.e-02
        rfq4(nc) = phim
        rfq6(nc) = a12
        rfq7(nc) = r0*1.e-02
        rfq8(nc) = a03*1.e12
        rfq9(nc) = fact
        rfq10(nc) = (1.+tvolt)*a(9)
        rfq11(nc) = (1.+avolt)*a(9)
        go to 50
        ! endif of itype(nc) = 0 (accelerating cell)
      end if
      if (itype(nc)==1) then
        ! ------ T-cell(ityp = 1) (must follows a standard cell and be followed by an M-cell or by fringe-field region)
        cl = a(1)
        xa = a(3)
        xm = a(4)
        r0 = a(5)
        phim = a(7)
        fact = 1. + a(8)
        xk = pi/(2.*cl)
        za0 = xk*xa
        zam = za0*xm
        ! Bessel functions
        no = 0
        bi0 = bint(no, za0)
        bim = bint(no, zam)
        bi3 = bint(no, 3.*za0)
        bim3 = bint(no, 3.*zam)
        ! coefficients A10 and A30 (no dimensions)
        t10k = xm*xm*bi0 + bim
        t30k = xm*xm*bi3 + bim3
        zr0 = xk*r0
        zr3 = 3.*zr0
        bir0 = bint(no, zr0)
        bir3 = bint(no, zr3)
        alpk = 0.
        if (abs(bir3)/=6.*0.) alpk = bir0/bir3
        dtk = t10k + alpk*t30k/3.
        a10 = 0.
        if (abs(dtk)/=6.*0.) a10 = (xm*xm-1.)/dtk
        a30 = alpk*a10/3.
        ! -- limits x-vane  y-vane
        cbx(nc) = xm*xa
        bbx(nc) = (4.*r0-xa-3.*cbx(nc))/(2.*cl)
        ablx(nc) = xa/(4.*cl*cl) - bbx(nc)/(2.*cl) - cbx(nc)/(4.*cl*cl)
        cby(nc) = xa
        bby(nc) = (4.*r0-xm*xa-3.*cby(nc))/(2.*cl)
        ably(nc) = xm*xa/(4.*cl*cl) - bby(nc)/(2.*cl) - cby(nc)/(4.*cl*cl)
        ! conversion: cm --> m
        cbx(nc) = cbx(nc)*1.e-02
        ablx(nc) = ablx(nc)*1.e02
        cby(nc) = cby(nc)*1.e-02
        ably(nc) = ably(nc)*1.e02
        ! end limits ******************************
        ! ---  convert all parameters in units (MeV, m)
        ! rfq1(nc): A30 (no dimension)
        ! rfq2(nc): A10 (no dimension)
        ! rfq3(nc): cell length (m)
        ! rfq4(nc): phase RF (deg)
        ! rfq7(nc): mean aperture of the vane r0 (m)
        ! rfq9(nc): factor to be applied at the inter-vane potentiel (only for particles)
        ! rfq10(nc):intervane voltage applied to the synchronous particle (KV)
        ! rfq11(nc):intervane voltage applied to the particles (KV)

        rfq1(nc) = a30
        rfq2(nc) = a10
        rfq3(nc) = cl*1.e-02
        rfq4(nc) = phim
        rfq7(nc) = r0*1.e-02
        rfq9(nc) = fact
        rfq10(nc) = (1.+tvolt)*a(9)
        rfq11(nc) = (1.+avolt)*a(9)
        go to 50
        ! endif for T-cell
      end if
      if (itype(nc)==2) then
        ! --- E-cell(itype = 2) must follow a RMS and be folllowed by an even standard cell
        cl = a(1)
        xa = a(3)
        xm = a(4)
        r0 = a(5)
        a(7) = fph*a(7)
        phim = a(7)
        fact = 1. + a(8)
        xk = pi/(2.*cl)
        za0 = xk*xa
        zam = za0*xm
        xam = xa*xm
        ! Bessel functions
        no = 0
        bi0 = bint(no, za0)
        bim = bint(no, zam)
        bi3 = bint(no, 3.*za0)
        bim3 = bint(no, 3.*zam)
        ! coefficients A10 and A30 (no dimensions)
        t10k = xm*xm*bi0 + bim
        t30k = xm*xm*bi3 + bim3
        zr0 = xk*r0
        zr3 = 3.*zr0
        bir0 = bint(no, zr0)
        bir3 = bint(no, 3.*zr3)
        alpk = 0.
        if (abs(bir3)/=6.*0.) alpk = bir0/bir3
        dtk = t10k + alpk*t30k/3.
        a10 = 0.
        if (abs(dtk)/=6.*0.) a10 = (xm*xm-1.)/dtk
        ! old   E-cell is a even cell number (followed by a odd number standard cell
        ! old        ncf=(nc/2)*2-nc
        ! old        if(ncf.eq.0) a10=-a10
        a30 = -alpk*a10/3.
        ! cell limits x-vane y-vane
        cbx(nc) = r0
        bbx(nc) = (xm*xa-r0)/cl
        ablx(nc) = 0.
        cby(nc) = r0
        bby(nc) = (xa-r0)/cl
        ably(nc) = 0.
        ! conversion: cm --> m
        cbx(nc) = cbx(nc)*1.e-02
        cby(nc) = cby(nc)*1.e-02
        ! ---  convert in units (MeV, m)
        ! rfq1(nc): A30 (no dimensions)
        ! rfq2(nc): A10 (no dimensions)
        ! rfq3(nc): cell length (m)
        ! rfq4(nc): phase RF (deg)
        ! rfq7(nc): mean aperture of the vane r0 (m)
        ! rfq9(nc): factor applied at the inter-vane potentiel
        ! rfq10(nc):intervane voltage applied to the synchronous particle (KV)
        ! rfq11(nc):intervane voltage applied to the particles (KV)
        rfq1(nc) = a30
        rfq2(nc) = a10
        rfq3(nc) = cl*1.e-02
        rfq4(nc) = phim
        rfq7(nc) = r0*1.e-02
        rfq9(nc) = fact
        rfq10(nc) = (1.+tvolt)*a(9)
        rfq11(nc) = (1.+avolt)*a(9)
        go to 50
      end if
      if (itype(nc)==3) then
        ! M-cell  (ityp = 3)
        cl = a(1)
        xa = a(3)
        xm = a(4)
        r0 = a(5)
        phim = a(7)
        fact = 1. + a(8)
        ! cell limits x-vane = y-vane = average radius
        cbx(nc) = r0
        bbx(nc) = 0.
        ablx(nc) = 0.
        cby(nc) = r0
        bby(nc) = 0.
        ably(nc) = 0.
        ! conversion: cm --> m
        cbx(nc) = cbx(nc)*1.e-02
        cby(nc) = cby(nc)*1.e-02
        ! end vanes limits ******************************
        ! ---  convert the parameters in units (MeV, m)
        ! rfq1(nc): A30 = 0
        ! rfq2(nc): A10 = 0
        ! rfq3(nc): cell length (m)
        ! rfq4(nc): phase RF (deg)
        ! rfq7(nc): mean aperture of the vane r0 (m)
        ! rfq9(nc): factor applied at the inter-vane potentiel(F = 1 + a(15))
        ! rfq10(nc):intervane voltage applied to the synchronous particle (KV)
        ! rfq11(nc):intervane voltage applied to the particles (KV)c
        rfq1(nc) = 0.
        rfq2(nc) = 0.
        rfq3(nc) = cl*1.e-02
        rfq4(nc) = phim
        rfq7(nc) = r0*1.e-02
        rfq9(nc) = fact
        rfq10(nc) = (1.+tvolt)*a(9)
        rfq11(nc) = (1.+avolt)*a(9)
        go to 50
        ! endif M-cell
      end if
      ! Fringe-field region after T-cell or M-cell  (Type = 4)
      if (itype(nc)==4) then
        cl = a(1)
        a10 = a(2)
        xa = a(3)
        xm = a(4)
        r0 = a(5)
        rh0 = a(6)
        phim = a(7)
        fact = 1. + a(8)
        ! fringe field region limits
        cbx(nc) = r0*1.5
        bbx(nc) = 0.
        ablx(nc) = 0.
        cby(nc) = r0*1.5
        bby(nc) = 0.
        ably(nc) = 0.
        ! conversion: cm --> m
        cbx(nc) = cbx(nc)*1.e-02
        cby(nc) = cby(nc)*1.e-02
        ! end limits ******************************
        ! ---  convert the parameters in units (MeV, m)
        ! rfq1(nc): A01 ( 1/(m*m) )
        ! rfq2(nc): A10 (no dimensions)
        ! rfq3(nc): cell length (m)
        ! rfq4(nc): phase RF (deg)
        ! rfq7(nc): mean aperture of the vane r0 (m)
        ! rfq9(nc): factor applied at the inter-vane potentiel (F = 1 + a(15))
        ! rfq10(nc):intervane voltage applied to the synchronous particle (KV)
        ! rfq11(nc):intervane voltage applied to the particles (KV)
        ! old        rfq1(nc)=a01*1.e04
        rfq2(nc) = a10
        rfq3(nc) = cl*1.e-02
        rfq4(nc) = phim
        rfq7(nc) = r0*1.e-02
        rfq9(nc) = fact
        rfq10(nc) = (1.+tvolt)*a(9)
        rfq11(nc) = (1.+avolt)*a(9)
      end if
      ! ********************************************
      ! fringe field region the profil is read from disk
      if (itype(nc)==7) then
        ! read the ff profile in the form (z,R(z)) in M
        ! npt is the number of coordinates (z,R(z)
        open (67, file=fprof, status='unknown')
        ! read(67,*)npf
        npf = 0
        do
          read (67, *, end=888) xspf(npf+1), yspf(npf+1)
          npf = npf + 1
        end do
888     write (16, *) 'RFQ FF from file with ', npf, ' data points'
        reca = xspf(1)
        do i = 1, npf
          xspf(i) = xspf(i) - reca
        end do
        ! length of the fringe field  m
        cl = xspf(npf)
        call derif2(npf)
        phim = a(7)
        fact = 1. + a(8)
        write (16, *) 'Fringe Field length=', cl, ' m'
        write (16, *) 'Fringe Field Phase=', phim
        write (16, *) 'Fringe Field Field Factor=', fact
        ! ---   limits x-vane y-vane
        cbx(nc) = 100.
        cby(nc) = 100.
        ablx(nc) = 0.
        ably(nc) = 0.
        bbx(nc) = 0.
        bby(nc) = 0.
        ! rfq1(nc) : not used
        ! rfq2(nc): not used
        ! rfq3(nc): Fringe field length (m)
        ! rfq4(nc): phase RF (deg)
        ! rfq7(nc): distance axe-vanes at the start of the FF (m)
        ! rfq9(nc): factor to be applied at the inter-vane potentiel (only for particles)
        ! rfq10(nc):intervane voltage applied to the synchronous particle (KV)
        ! rfq11(nc):intervane voltage applied to the particles (KV)
        rfq1(nc) = 0.
        rfq2(nc) = 0.
        rfq3(nc) = cl
        rfq4(nc) = phim
        rfq7(nc) = r0
        rfq9(nc) = fact
        rfq10(nc) = (1.+tvolt)*a(9)
        rfq11(nc) = (1.+avolt)*a(9)
        close (67)
        ! cc        write(16,579)nc,npt,cl,phim,r0,rfq10(nc),rfq11(nc)
        ! cc579     format(2(2x,i4),5(2x,e12.5))
      end if
      ! ********************************************
60    continue
      if (netc<nceltot) then
        write (6, *) 'Error: Parameter NCELTOT after RFQPTQ entry in', ' DYNAC input file is ', nceltot
        write (6, *) 'This is larger than the', ' number of cells in the RFQ datafile, which is ', netc
        write (16, *) 'Error: Parameter NCELTOT after RFQPTQ entry in', ' DYNAC input file is ', nceltot
        write (16, *) 'This is larger than the', ' number of cells in the RFQ datafile, which is ', netc
        stop
      end if
      call rfq_parm
      return
    end subroutine cpardyn
    ! *******************************************************************
    ! function bint(n,z)
    ! ---  integral representation of modified Bessel functions
    ! n integer order    z argument
    ! *******************************************************************
    function bint(n, z)
      implicit real *8(a-h, o-z)
      common /consta/vl, pi, xmat, rpel, qst
      dimension ui(16), wi(16)
      ! GAUSS n=16 de -1. a 1
      data (ui(j), j=1, 16)/ -.9894009, -.9445750, -.8656312, -.7554044, -.6178762, -.4580168, -.2816036, -.0950125, &
        .0950125, .2816036, .4580168, .6178762, .7554044, .8656312, .9445750, .9894009/
      data (wi(j), j=1, 16)/.0271524, .0622535, .0951585, .1246288, .1495960, .1691565, .1826034, .1894506, .1894506, &
        .1826034, .1691565, .1495960, .1246288, .0951585, .0622535, .0271524/

      bint = 0.
      do i = 1, 16
        thet = pi/2.*(1.+ui(i))
        fln = float(n)
        cthet = cos(thet)
        fonc = exp(cthet*z)*cos(fln*thet)
        bint = bint + fonc*wi(i)
      end do
      bint = bint/2.
      return
    end function bint
    ! *******************************************************************
    ! SUBROUTINE accep_rfq(pib)
    ! Do so by shifting particles belonging to the same bunch from
    ! outside to inside (+/-) pi w.r.t.the synchronous particle
    ! *******************************************************************
    subroutine accep_rfq(pib)
      implicit real *8(a-h, o-z)
      parameter(iptsz=100002, maxcell=3000, maxcell1=3000)
      common /consta/vl, pi, xmat, rpel, qst
      common /faisc/f(10, iptsz), imax, ngood
      common /etcha1/dav2(maxcell1, 33), ichas(iptsz), chasit
      common /sc3/beamc, scdist, sce10, cplm, ectt, apl, ichaes, iscsp
      common /ttfc/tk, t1k, t2k, sk, s1k, s2k, fh
      common /dyn/tref, vref
      common /mcs/imcs, ncstat, cstat(20)
      common /tapes/in, ifile, meta
      common /etcha3/ichxyz(iptsz)
      common /rec/irec
      common /etcom/cog(8), exten(17), fd(iptsz)
      logical chasit
      ! character*80 wfile
      do ite = 1, 3
        do i = 1, ngood
          drad = (f(6,i)-tref)*fh
          if (drad>pib) then
            ! old             f(6,i)=(f(6,i)-pi/fh)
            f(6, i) = (f(6,i)-2.*pi/fh)
          end if
          if (drad<-pib) then
            ! old             f(6,i)=(f(6,i)+pi/fh)
            f(6, i) = (f(6,i)+2.*pi/fh)
          end if
        end do
      end do
      tcog = 0.
      ! --- cog in time of bunch after reinjecting particles into the bunch
      do i = 1, ngood
        tcog = tcog + f(6, i)
      end do
      tcog = tcog/float(ngood)
      ! tref=tcog
      write (16, 59) tcog*fh*180./pi
59    format (' Phase of COG after reinjecting particles into the ', 'bunch: ', e13.7, ' deg')
      return
    end subroutine accep_rfq
    ! *******************************************************************
    ! SUBROUTINE rfq_parm
    ! NOTE:
    ! The reference particle and particles may evolve separately or
    ! may be connected
    ! Only the SCHEFF space charge method is available
    ! Space charge computations are automaticaly made at the middle
    ! of each cell
    ! -------------------------------------------------------------------
    ! Radial matching section
    ! rfq1(nc): Aq (no dimension)
    ! rfq2(nc): not used
    ! rfq3(nc): RMS length (m)
    ! rfq4(nc): phase RF (deg)
    ! rfq7(nc): mean aperture of the vane r0 (m)
    ! rfq9(nc): factor to be applied at the inter-vane potentiel
    ! (only for particles)
    ! rfq10(nc):intervane voltage applied to the synchronous
    ! particle (KV)
    ! rfq11(nc):intervane voltage applied to the particles (KV)

    ! ---- standard accelerating cells (ityp = 0)
    ! rfq1(nc): A01 ( 1/(m*m) )
    ! rfq2(nc): A10 (no dimensions)
    ! rfq3(nc): cell length (m)
    ! rfq4(nc): phase RF (deg)
    ! rfq6(nc): A12 (no dimension)
    ! rfq7(nc): mean aperture of the vane r0 (m)
    ! rfq8(nc): A03 (1/(m**6)
    ! rfq9(nc): factor F = 1 + a() (only for inter-vane potentiel
    ! of particles)
    ! rfq10(nc):intervane voltage applied to the synchronous
    ! particle (KV)
    ! rfq11(nc):intervane voltage applied to the particles (KV)
    ! ---  odds cells have a01 positive, even cells have a01 negative

    ! ----  transition T-cell and E-cell
    ! rfq1(nc): A30 (no dimensions)
    ! rfq2(nc): A10 (no dimensions)
    ! rfq3(nc): cell length (m)
    ! rfq4(nc): phase RF (deg)
    ! rfq7(nc): mean aperture of the vane r0 (m)
    ! rfq9(nc): factor F = 1 + a(8)
    ! rfq10(nc):intervane voltage applied to the synchronous
    ! particle (KV)
    ! rfq11(nc):intervane voltage applied to the particles (KV)

    ! ----  M-cell
    ! rfq1(nc): A30 = 0
    ! rfq2(nc): A10 = 0
    ! rfq3(nc): cell length (m)
    ! rfq4(nc): phase RF (deg)
    ! rfq7(nc): mean aperture of the vane r0 (m)
    ! rfq9(nc): factor F = 1 + a(8)
    ! rfq10(nc):intervane voltage applied to the synchronous
    ! particle (KV)
    ! rfq11(nc):intervane voltage applied to the particles (KV)

    ! ---- Fringe-field region from the potential function (F-cell)
    ! rfq1(nc): A01 ( 1/(m*m) )
    ! rfq2(nc): A10 (no dimensions)
    ! rfq3(nc): cell length (m)
    ! rfq4(nc): phase RF (deg)
    ! rfq7(nc): mean aperture of the vane r0 (m)
    ! rfq9(nc): factor F = 1 + a(8)
    ! rfq10(nc):intervane voltage applied to the synchronous
    ! particle (KV)
    ! rfq11(nc):intervane voltage applied to the particles (KV)

    ! ---- Fringe-field region the profil is read on the disk (F-cell)
    ! rfq1(nc): not used
    ! rfq2(nc): not used
    ! rfq3(nc): cell length (m)
    ! rfq4(nc): phase RF (deg)
    ! rfq7(nc): mean aperture of the vane r0 (m) (not used)
    ! rfq9(nc): factor F = 1 + a(8)
    ! rfq10(nc):intervane voltage applied to the synchronous
    ! particle (KV)
    ! rfq11(nc):intervane voltage applied to the particles (KV)

    ! *******************************************************************
    subroutine rfq_parm
      implicit real *8(a-h, o-z)
      parameter(iptsz=100002, maxcell=3000, maxcell1=3000)
      common /rigid/boro
      common /consta/vl, pi, xmat, rpel, qst
      common /dyn/tref, vref
      common /ttfc/tk, t1k, t2k, sk, s1k, s2k, fh
      common /faisc/f(10, iptsz), imax, ngood
      common /tapes/in, ifile, meta
      common /davcom/dav1(maxcell1, 40), davtot, iitem(maxcell1), idav
      common /etcom/cog(8), exten(17), fd(iptsz)
      common /sc3/beamc, scdist, sce10, cplm, ect, apl, ichaes, iscsp
      common /fene/wdisp, wphas, wx, wy, rlim, ifw
      common /dcspa/iesp
      common /pltprf/sprfx(3000), sprfy(3000), sprfl(3000), sprfw(3000), sprfp(3000), sprng(3000), iprf
      common /compt/nrres, nrtre, nrbunc, nrdbun
      common /shif/dtiph, shift
      common /femt/iemgrw, iemqesg
      common /posc/xpsc
      common /cgtof/charm(20), cgtdv(20), nbch(20), netac
      ! common/drfq/p(9)
      common /azlist/icont, iprin
      common /trfq/icour, ncell
      logical iesp, ichaes, shift, iemgrw, iflag
      common /itvole/itvol, imamin
      common /tofev/ttvols
      common /rf1ptq/tvolt, avolt, fph, mlc, nceltot
      common /rf2ptq/rfq1(500), rfq2(500), rfq3(500), rfq4(500), rfq6(500), rfq7(500), rfq8(500), rfq9(500)
      common /rf5ptq/tdvolt, rfq10(500), rfq11(500)
      ! old       common/rfq3ptq/itype(500),evens,evenr
      common /rfq3ptq/itype(500), ipari(500), evens, evenr
      common /bonda/cbx(500), bbx(500), ablx(500), cby(500), bby(500), ably(500)
      logical itvol, imamin
      common /conti/irfqp
      common /spl/xspl(4000), yspl(4000), s(5000), p(5000), q(5000)
      common /spff/xspf(400), yspf(400), sf(500), pf(500), qf(500)
      common /rms_prfl/npt, npf
      ! ********************************************
      ! v28/04/2015
      common /fcont/ifcont
      logical ifcont
      ! ********************************************
      ! logical irfqp,evens,evenr,evenf
      logical irfqp, evens, evenr
      dimension rfqdmp(500, 10)
      character *1 cr
      ! allow for print out on terminal of cell# on one and the same line
      cr = char(13)
      irfqp = .true.
      iflag = .false.
      radian = pi/180.
      ilost = 0
      twopi = 2.*pi
      ! convert vl in m
      vlm = vl/100.
      wavel = 2.*pi*vlm/fh
      er = xmat
      ! STATISTIQUES FOR PLOTS
      if (iprf==1) call stapl(davtot*10.)
      ! start prints in file 'short.data'
      tlgth = 0.
      idav = idav + 1
      iitem(idav) = 15
      dav1(idav, 9) = tdvolt*1000.
      dav1(idav, 7) = float(nceltot)
      dav1(idav, 8) = tdvolt*1000.
      ! --- end daves
      ! ns = 18: number of steps in cells (apart for the fringe field region and RMS)
      xlrfq = 0.
      ! the integer nn is only used if the RMS profile is required
      nn = 0
      do ncell = 1, nceltot
        write (6, 8254) nrtre, ncell, cr
8254    format ('Transport element:', i5, '      RFQ cell :', i5, '            ', a1, $)
        ns = 18
        if (itype(ncell)==5) ns = 126
        if (itype(ncell)==6) ns = 126
        nsm = ns/2
        r0 = rfq7(ncell)
        cl = rfq3(ncell)
        davtot = davtot + cl*100.
        xlrfq = xlrfq + cl*100.
        if (itype(ncell)==0) then
          ! ------------- accelerating cells(ityp = 0)
          ! --- synchronous particle
          rtvolt = rfq10(ncell)
          vorsq = rfq1(ncell)*rtvolt
          av = rfq2(ncell)*rtvolt
          a12v = rfq6(ncell)*rtvolt
          ! --- particles
          pavolt = rfq11(ncell)
          vorb = rfq1(ncell)*pavolt*rfq9(ncell)
          avb = rfq2(ncell)*pavolt*rfq9(ncell)
          a12vb = rfq6(ncell)*pavolt*rfq9(ncell)
          a03vb = rfq8(ncell)*pavolt*rfq9(ncell)
        end if
        if (itype(ncell)==1) then
          ! ---------------- T-cell(Type = 1)
          ! ---- synchronous particle
          rtvolt = rfq10(ncell)
          a31v = rfq1(ncell)*rtvolt
          a10v = rfq2(ncell)*rtvolt
          ! ---- particles (field)
          pavolt = rfq11(ncell)
          a31vb = rfq1(ncell)*pavolt*rfq9(ncell)
          av10b = rfq2(ncell)*pavolt*rfq9(ncell)
        end if
        if (itype(ncell)==2) then
          ! --------   E-cell(Type = 2)
          ! ---- synchronous particle
          rtvolt = rfq10(ncell)
          a31v = rfq1(ncell)*rtvolt
          a10v = rfq2(ncell)*rtvolt
          ! ---- particles
          pavolt = rfq11(ncell)
          a31vb = rfq1(ncell)*pavolt*rfq9(ncell)
          a10vb = rfq2(ncell)*pavolt*rfq9(ncell)
        end if
        if (itype(ncell)==4) then
          ! -------, F-cell (ityp = 4)
          ! --- synchronous particle
          rtvolt = rfq10(ncell)
          av = rfq2(ncell)*rtvolt
          ! --- particles
          pavolt = rfq11(ncell)
          avb = rfq2(ncell)*pavolt*rfq9(ncell)
        end if
        ! ********************************************
        ! fringe field type 7
        if (itype(ncell)==7) then
          ! -------, F-cell (ityp = 7)
          ! --- synchronous particle
          rtvolt = rfq10(ncell)
          ! --- particles
          pavolt = rfq11(ncell)
          a31vb = pavolt*rfq9(ncell)
        end if
        ! ********************************************
        ! -----Radial matching section from potential function(Type = 5)
        if (itype(ncell)==5) then
          ! ---- synchronous particle
          rtvolt = rfq10(ncell)
          a31v = rfq1(ncell)*rtvolt
          a10v = rfq2(ncell)*rtvolt
          ! ---- particles (field)
          pavolt = rfq11(ncell)
          a31vb = rfq1(ncell)*pavolt*rfq9(ncell)
          av10b = rfq2(ncell)*pavolt*rfq9(ncell)
        end if
        ! -----Radial matching section with vanes profile read from disk (Type = 6)
        if (itype(ncell)==6) then
          ! ---- potential applied to the synchronous particle
          rtvolt = rfq10(ncell)
          ! ---- potenatial applied to particles
          pavolt = rfq11(ncell)
          a31vb = pavolt*rfq9(ncell)
        end if
        ! c.o.g of the bunch
        tcog = 0.
        ecog = 0.
        do i = 1, ngood
          tcog = tcog + f(6, i)
          ecog = ecog + f(7, i)
        end do
        tcog = tcog/float(ngood)
        ecog = ecog/float(ngood)
        gcog = ecog/er
        bcog = sqrt(1.-1./(gcog*gcog))
        wcog = ecog - er
        if (ncell==1) then
          ! ---- shift = .false. ==> the synchronous particle is the center of gravity
          if (.not. shift) then
            tref = tcog
            bref = bcog
            vref = bref*vl
            gref = gcog
            wref = wcog
            wrefi = wref
          else
            ! ---- shift = .true. ==> the synchronous particle and the c.o.g are separated
            bref = vref/vl
            gref = 1./sqrt(1.-bref*bref)
            wref = er*(gref-1.)
            wrefi = wref
          end if
        end if
        ! --- standard accelerating cell (itype = 0)
        if (itype(ncell)==0) cay = pi/cl
        ! ---  T-cell(itype = 1 , E-cell(itype = 2, fringe field region(itype = 4) RMS (itype = 5)
        if (itype(ncell)==1) cay = pi/(2.*cl)
        if (itype(ncell)==2) cay = pi/(2.*cl)
        if (itype(ncell)==5) cay = pi/(2.*cl)
        if (itype(ncell)==6) cay = pi/(2.*cl)
        ! --- fringe field region type 4
        if (itype(ncell)==4) then
          cay = pi/(2.*cl)
          ns = int(36.*cl/(bref*wavel))
          if (ns<=5) ns = 6
          nsm = ns/2
        end if
        ! ********************************************
        ! Fringe field region type 7
        if (itype(ncell)==7) then
          cay = pi/(2.*cl)
          ns = int(36.*cl/(bref*wavel))
          ns = 3*ns
          ! old           if(ns.le.5) ns=6
          nsm = ns/2
        end if
        ! ********************************************
        ! ---  M-cell (itype = 3)
        ! old sv         if(itype(ncell).eq.3) cay=pi/cl
        xl = cl/float(ns)
        hl = .5*xl
        ! ----  scl: space charge length in SCHEFF unit (cm)
        scl = cl*100.
        ! ----  phini: phase of the synchronous at input of the cell
        phini = -tref*fh + rfq4(ncell)*radian
        if (ncell==1) then
          write (16, 178)
178       format (/, ' Dynamics at the input', /, 5x, '   BETA     GAMMA      ENERGY(MeV) ', &
            '       TOF(deg)     TOF(sec)')
          write (16, 1788) bcog, gcog, wcog, tcog*fh*180./pi, tcog
1788      format (' COG ', f7.5, 3x, e12.5, 1x, e12.5, 3x, e12.5, 3x, e12.5)
          write (16, 165) bref, gref, wref, tref*fh*180./pi, tref
165       format (' REF ', f7.5, 3x, e12.5, 1x, e12.5, 3x, e12.5, 3x, e12.5)
          write (16, *)
          write (75, 9627)
9627      format (5x, 'ncell', 4x, 'A01(m-2)', 8x, 'A10', 12x, 'A12', 11x, 'r0(m)', 11x, 'A03(m-6)')
          write (70, 9977)
9977      format (5x, 'ncell', 4x, 'Zcell(m)', 7x, 'Z(m)', 9x, 'Phi(deg)', 8x, 'Pho(deg)', 7x, 'Wsyn', 11x, 'Wcog', 9x, &
            'ngood')
          write (89, 9888)
9888      format (4x, 'ncell', 1x, 'z(m) middle', 4x, 'phini(deg)', 5x, 'phmid(deg)')
        end if
        z = 0.
        ! ---- iterations over steps xl
        nsp1 = ns + 1
        do n = 1, nsp1
          z = z + hl
          if (z>cl) then
            zl = z - hl
            tlgth = tlgth + zl
            phfin = tref*fh + phini
            phfin = phfin*180./pi
            ! cc            phfin=phref*180./pi
            if (ncell==1) then
              rfqdmp(ncell, 1) = zl
            else
              rfqdmp(ncell, 1) = zl + rfqdmp(ncell-1, 1)
            end if
            rfqdmp(ncell, 2) = phdep
            write (70, 9999) ncell, zl, tlgth, phdep, phfin, wref, wcog, ngood
9999        format (2x, i5, 6(3x,e12.5), 3x, i6)
            go to 9527
          end if
          ! --- change of reference over the half step hl
          tref = tref + hl/(bref*vlm)
          if (itvol) ttvols = tref
          phref = tref*fh + phini
          skz = sin(cay*z)
          ckz = cos(cay*z)
          ! ---  synchronous particle
          ! change of energy over the step xl
          sp = sin(phref)
          ! standard accelerating cell
          if (itype(ncell)==0) then
            dwref = .5*qst*cay*av*skz*sp*xl
            ! print in file rfq_list1.data
            if (n==1) phdep = rfq4(ncell)
          end if
          ! T-cell (type = 1)
          if (itype(ncell)==1) then
            skz3 = sin(3.*cay*z)
            ckz3 = cos(3.*cay*z)
            dwref = 0.5*qst*cay*(a10v*skz+3.*a31v*skz3)*sp*xl
            ! print in file rfq_list1.data
            if (n==1) phdep = rfq4(ncell)
          end if
          ! E-cell (type = 2)
          if (itype(ncell)==2) then
            skz3 = sin(3.*cay*z)
            ckz3 = cos(3.*cay*z)
            dwref = 0.5*qst*cay*(a10v*ckz+3.*a31v*ckz3)*sp*xl
            ! print in file rfq_list1.data
            if (n==1) phdep = rfq4(ncell)
          end if
          ! M-cell (type = 3)
          if (itype(ncell)==3) then
            dwref = 0.
            ! print in file rfq_list1.data
            if (n==1) phdep = rfq4(ncell)
          end if
          ! Fringe-field region (itype = 4)
          if (itype(ncell)==4) then
            rtvolt = rfq10(ncell)
            av = rfq2(ncell)*rtvolt
            c3kz = cos(3.*cay*z)
            skpz = .75*(skz+sin(3.*cay*z))
            dwref = .5*qst*cay*av*skpz*sp*xl
            ! print in file rfq_list1.data
            if (n==1) phdep = rfq4(ncell)
          end if
          ! ********************************************
          ! Fringe-field region (itype = 7)
          if (itype(ncell)==7) then
            dwref = 0.
            ! rprof: current fringe field profile at the azimutal position z
            c3kz = cos(3.*cay*z)
            rproff = splinf(npf, z)
            ! old              write(16,*) 'FF z,radius ',z,rproff
            ! print in file rfq_list1.data
            if (n==1) phdep = rfq4(ncell)
          end if
          ! ********************************************
          ! --- RMS (type = 5)
          if (itype(ncell)==5) then
            dwref = 0.
            ! print in file rfq_list1.data
            if (n==1) phdep = rfq4(ncell)
          end if
          ! --- RMS (type = 6)
          if (itype(ncell)==6) then
            dwref = 0.
            ! rprof: current RMS profile given at z
            rprof = spline(npt, z)
            ! cc            write(16,4527) n,z,rprof,a31vb
            ! cc4527        format(2x,i4,3(2x,e12.5))
            ! print in file rfq_list1.data
            if (n==1) phdep = rfq4(ncell)
          end if
          ! --- gain of energy (synchronous particle)
          wrefm = wref + 0.5*dwref
          grefm = wrefm/er + 1.
          brefm = sqrt(1.-1./(grefm*grefm))
          wref = wref + dwref
          gref = wref/er + 1.
          bref = sqrt(1.-1./(gref*gref))
          dez = 0.
          dref = 0.
          ! ---- Beam
          ! coordinates x, xp,y, yp convert in m and rad
          do ip = 1, ngood
            xi = f(2, ip)*1.e-02
            xpi = f(3, ip)*1.e-03
            yi = f(4, ip)*1.e-02
            ypi = f(5, ip)*1.e-03
            ww = f(7, ip) - er
            ! remove from the bunch particles that have energy < 0
            if (ww<0.) then
              f(8, ip) = 0.
              ilost = ilost + 1
              write (49, 5558) ip, ncell, ww
              iflag = .true.
              go to 6525
            end if
5558        format (' particle: ', i5, ' cell: ', i5, ' energy: ', e12.5)
            gi = ww/er + 1.
            if (gi<1.) then
              f(8, ip) = 0.
              ilost = ilost + 1
              ! needs to be on energy
              write (49, *) ' particle lost: ', i, ' W: ', ww, ' MeV'
              iflag = .true.
              go to 6525
            end if
            bi = sqrt(1.-1./(gi*gi))
            bgi = bi*gi
            ! move particles back in the bunch if they have abs(phi) > pi
            tim = f(6, ip) + hl/(bi*vlm)
            phi = fh*(tim-tref)
            if (phi>=pi) then
              f(6, ip) = f(6, ip) - 2.*pi/fh
              tim = f(6, ip) + hl/(bi*vlm)
              phi = fh*(tim-tref)
              if (abs(phi)>pi) then
                f(8, ip) = 0.
                ilost = ilost + 1
                write (49, 5559) ip, ncell, phi, f(9, ip)
                iflag = .true.
                go to 6525
              end if
            end if
            if (phi<=-pi) then
              f(6, ip) = f(6, ip) + 2.*pi/fh
              tim = f(6, ip) + hl/(bi*vlm)
              phi = fh*(tim-tref)
              if (abs(phi)>pi) then
                f(8, ip) = 0.
                ilost = ilost + 1
                write (49, 5559) ip, ncell, phi, f(9, ip)
                iflag = .true.
                go to 6525
              end if
            end if
5559        format (' particle: ', i5, ' cell: ', i5, ' phi(rad): ', e12.5, ' charge state ', f6.2)
            tim = f(6, ip) + hl/(bi*vlm)
            phi = phini + fh*tim
            qq = abs(f(9,ip))
            sp = sin(phi)
            cp = cos(phi)
            bav = bi
            gav = gi
            bgav = bgi
            bg = bgi
            beta = bi
            delt = 0.
            amort = 1.
            xm = xi + xpi*hl
            ym = yi + ypi*hl
            rm = sqrt(xm*xm+ym*ym)
            ! ---- particle is lost if abs(xm) > vanx or abs(ym) > vany
            if (n/=ns/2) then
              vanx = ablx(ncell)*z*z + bbx(ncell)*z + cbx(ncell)
              vany = ably(ncell)*z*z + bby(ncell)*z + cby(ncell)
              vanx = vanx*0.7523
              vany = vany*0.7523
              if (abs(xm)>=vanx) f(8, ip) = 0.
              if (abs(ym)>=vany) f(8, ip) = 0.
              if (f(8,ip)==0.) then
                ilost = ilost + 1
                write (49, 5556) ip, ncell, abs(xm), vanx, abs(ym), vany, rm
5556            format (' particle: ', i5, ' cell: ', i5, ' abs(x) (m): ', e12.5, ' x-v(m): ', e12.5, ' abs(y) (m):', &
                  e12.5, ' y-v(m): ', e12.5, ' radius (m) ', e12.5)
                iflag = .true.
                go to 6525
              end if
            end if
            if (n==ns/2) then
              if (rm>r0) then
                f(8, ip) = 0.
                ilost = ilost + 1
                write (49, 5557) ip, ncell, rm, r0
5557            format (' particle: ', i5, ' cell: ', i5, ' radius (ptcl) (m): ', e12.5, ' radius (cell) (m):', e12.5)
                iflag = .true.
                go to 6525
              end if
            end if
            theta = 0.
            signx = 0.
            signy = 0.
            xml = xm
            yml = ym
            if (abs(xm)>1.e-10) then
              theta = atan(ym/xm)
              signx = 1.
              signy = 1.
              if (theta>0.) then
                if (xm<0.) signx = -1.
                if (ym<0.) signy = -1.
              end if
              if (theta<0.) then
                if (xm<0.) signx = -1.
                if (ym>0.) signy = -1.
              end if
            end if
            if (abs(xm)<=1.e-10) then
              if (abs(ym)>1.e-10) then
                if (xm>=0. .and. ym>0.) theta = pi/2
                if (xm>=0. .and. ym<0.) theta = -pi/2
                if (xm<0. .and. ym<0.) theta = pi/2
                if (xm<0. .and. ym>0.) theta = -pi/2
              end if
            end if
            if (theta==0.) then
              signx = 0.
              signy = 0.
            end if
            ! ----  standard accelerating cell
            if (itype(ncell)==0) then
              zrm = cay*rm
              ! ----- Bessel functions: I0 to I4
              bi0 = 1. + zrm*zrm/4. + zrm**4/64.
              ! old     *     +zrm**6/2304 +zrm**8/1.47456e05
              ! old      bi0=bi0+zrm**10/1.47456e07
              ! old             bi1=zrm/2.+zrm**3/16.+zrm**5/128.
              bi1 = zrm/2. + zrm**3/16.
              bi1p = 0.
              if (rm/=6.*0.) bi1p = bi1/rm
              bi3 = zrm**3/48. + zrm**5/768
              bi4 = zrm**4/384.
              bi4r = 0.
              if (rm>1.e-06) bi4r = bi4/rm
              bi5 = zrm**5/3840.
              c2t = cos(2.*theta)
              s2t = sin(2.*theta)
              c1t = cos(theta)
              s1t = sin(theta)
              ! ---   transverse fields (cylindrical coordinates)
              erf = vorb*c2t*2.*rm + cay*(avb*bi1+a12vb*(bi3+bi5)*cos(4.*theta)/2.)*ckz
              erf = -erf/2.
              etf = vorb*s2t*2.*rm + 4.*a12vb*bi4r*sin(4.*theta)*ckz
              etf = etf/2.
              ! old sv            evens=.false.
              ! old            ncf=(ncell/2)*2-ncell
              ncf = (ipari(ncell)/2)*2 - ipari(ncell)
              if (ncf==0) then
                erf = -erf
                etf = -etf
                ! old sv            evens=.true.
              end if
              ! cartesian fields Ex and Ey
              ex = erf*c1t - etf*s1t
              ey = erf*s1t + etf*c1t
              ex = signx*ex
              ey = signy*ey
            end if
            ! ---- T-cell (Type = 1)
            if (itype(ncell)==1) then
              ! transverse fields (cylindrical coordinates)
              zrm = cay*rm
              zrm3 = zrm*3.
              bi0 = 1. + zrm*zrm/4. + zrm**4/64. + zrm**6/2304.
              ! old     *              +zrm**8/1.47456e05
              bi03 = 1. + zrm3*zrm3/4. + zrm3**4/64. + zrm3**6/2304.
              ! old     *              +zrm**8/1.47456e05
              bi1 = zrm/2. + zrm**3/16. + zrm**5/384.
              ! old             bi1p=0.
              ! old             if(rm.ne.6.*0.) bi1p=bi1/rm
              bi13 = zrm3/2. + zrm3**3/16. + zrm3**5/384.
              ! old             bi13p=0.
              ! old             if(rm.ne.6.*0.) bi13p=bi13/rm
              c2t = cos(2.*theta)
              s2t = sin(2.*theta)
              c1t = cos(theta)
              s1t = sin(theta)
              pavolt = rfq11(ncell)
              rpv = pavolt*rfq9(ncell)
              ncf = (ipari(ncell)/2)*2 - ipari(ncell)
              if (ncf==0) then
                rpv = -rpv
                erf = -rpv/(r0*r0)*c2t*rm
                erf = erf + cay/2.*(av10b*bi1*ckz+3.*a31vb*bi13*ckz3)
                etf = rpv/(r0*r0)*s2t*rm
              else
                erf = -rpv/(r0*r0)*c2t*rm
                erf = erf - cay/2.*(av10b*bi1*ckz+3.*a31vb*bi13*ckz3)
                etf = rpv/(r0*r0)*s2t*rm
              end if
              ex = erf*c1t - etf*s1t
              ey = erf*s1t + etf*c1t
              ex = signx*ex
              ey = signy*ey
            end if
            ! tof over the length xl
            ! ---- E-cell (Type = 2)
            if (itype(ncell)==2) then
              ! ---   transverse fields (cylindrical coordinates)
              zrm = cay*rm
              zrm3 = zrm*3.
              bi0 = 1. + zrm*zrm/4. + zrm**4/64. + zrm**6/2304.
              ! old     *              +zrm**8/1.47456e05
              bi03 = 1. + zrm3*zrm3/4. + zrm3**4/64. + zrm3**6/2304.
              ! old     *              +zrm**8/1.47456e05
              bi1 = zrm/2. + zrm**3/16. + zrm**5/384.
              ! old             bi1p=0.
              ! old             if(rm.ne.6.*0.) bi1p=bi1/rm
              bi13 = zrm3/2. + zrm3**3/16. + zrm3**5/384.
              ! old             bi13p=0.
              ! old             if(rm.ne.6.*0.) bi13p=bi13/rm
              c2t = cos(2.*theta)
              s2t = sin(2.*theta)
              c1t = cos(theta)
              s1t = sin(theta)
              pavolt = rfq11(ncell)
              rpv = pavolt*rfq9(ncell)
              erf = -rpv/(r0*r0)*c2t*rm
              ! *et*2015-07-07*s
              ! erf=erf+0.5*cay*(av10b*bi1*skz+3.*a31vb*bi13*skz3)
              erf = erf + 0.5*cay*(a10vb*bi1*skz+3.*a31vb*bi13*skz3)
              ! *et*2015-07-07*e
              etf = rpv/(r0*r0)*s2t*rm
              ! control polarity of the cell
              ! old            ncf=(ncell/2)*2-ncell
              ncf = (ipari(ncell)/2)*2 - ipari(ncell)
              if (ncf==0) then
                erf = -erf
                etf = -etf
              end if
              ex = erf*c1t - etf*s1t
              ey = erf*s1t + etf*c1t
              ex = signx*ex
              ey = signy*ey
            end if
            ! ---- M-cell (Type = 3)
            if (itype(ncell)==3) then
              c2t = cos(2.*theta)
              s2t = sin(2.*theta)
              c1t = cos(theta)
              s1t = sin(theta)
              pavolt = rfq11(ncell)
              rpv = pavolt*rfq9(ncell)
              erf = -rpv/(r0*r0)*c2t*rm
              etf = rpv/(r0*r0)*s2t*rm
              ! ---- M-cell (Type = 3)
              ! old            if(itype(ncell).eq.3) then
              ! old             c2t=cos(2.*theta)
              ! old             s2t=sin(2.*theta)
              ! old             c1t=cos(theta)
              ! old             s1t=sin(theta)
              ! old             pavolt=rfq11(ncell)
              ! old             rpv=pavolt*rfq9(ncell)
              ! old             erf=-rpv/(r0*r0)*c2t*rm
              ! old             etf=rpv/(r0*r0)*s2t*rm
              ! old             c3kz=cos(3.*cay*z)
              ! old            erf=erf*(ckz+c3kz/3.)*0.75
              ! old            etf=etf*(ckz+c3kz/3.)*0.75
              ! *************************************************
              ! control polarity of the cell
              ! old            ncf=(ncell/2)*2-ncell
              ncf = (ipari(ncell)/2)*2 - ipari(ncell)
              if (ncf==0) then
                erf = -erf
                etf = -etf
              end if
              ex = erf*c1t - etf*s1t
              ey = erf*s1t + etf*c1t
              ex = signx*ex
              ey = signy*ey
            end if
            ! ---- Radial matching section (type = 5)
            if (itype(ncell)==5) then
              c2t = cos(2.*theta)
              s2t = sin(2.*theta)
              c1t = cos(theta)
              s1t = sin(theta)
              skz3 = sin(3.*cay*z)
              ckz3 = cos(3.*cay*z)
              zrm = cay*rm
              b2kr = zrm*zrm/8.
              b2kr3 = (9./8.)*zrm*zrm
              qzrm = 0.
              erf = 0.
              etf = 0.
              if (rm>6*0.) then
                qzrm = (b2kr*skz-(1./27.)*b2kr3*skz3)
                erf = -1./8.*a31vb*cay*cay*(skz-1/3.*skz3)*c2t
                erf = erf*rm
                etf = a31vb*qzrm*s2t/rm
              end if
              ex = erf*c1t - etf*s1t
              ey = erf*s1t + etf*c1t
              ex = signx*ex
              ey = signy*ey
            end if
            ! ****************************************************
            if (itype(ncell)==6) then
              bgfac = gav*bav**2
              cc = a31vb*qq*xl*sp/(bgfac*er)
              rr1 = -cc/(rprof*rprof)
              rr2 = cc/(rprof*rprof)
              rr1 = rr1*xm
              rr2 = rr2*ym
            end if
            ! ********************************************
            ! Fringe field profil from the disk (type 7)
            if (itype(ncell)==7) then
              bgfac = gav*bav**2
              c1 = .75*(ckz+c3kz/3.)
              cc = a31vb*qq*xl*sp/(bgfac*er)
              rr1 = -cc/(rproff*rproff)
              rr2 = cc/(rproff*rproff)
              ! test the cell parity
              ncf = (ipari(ncell)/2)*2 - ipari(ncell)
              if (ncf==0) then
                rr1 = -rr1
                rr2 = -rr2
              end if
              rr1 = rr1*xm
              rr2 = rr2*ym
              ! old       if(ip.eq.25) write(16,5287)n,z,rproff,rr1/xm,rr2/ym
              ! 5287       format(2x,i4,4(2x,e12.5))
            end if
            ! ********************************************
            ! ----  CHANGE ENERGY OVER the STEP XL
            ! ------  standard accelerating cell or R-cell (Type = 0)
            if (itype(ncell)==0) then
              ez = 0.5*(avb*bi0+a12vb*bi4*cos(4.*theta))*skz*cay
              ! 2014 a12test line above replaced by line below
              ! ez=0.5*(avb*bi0)*skz*cay
              dw = qq*ez*sp*xl
            end if
            ! -------  T-cell (Type = 1)
            if (itype(ncell)==1) then
              ez = 0.5*cay*(av10b*skz*bi0+3.*a31vb*skz3*bi03)
              dw = qq*ez*sp*xl
            end if
            ! -------  E-cell (Type = 2)
            if (itype(ncell)==2) then
              ez = 0.5*cay*(a10vb*ckz*bi0+3.*a31vb*ckz3*bi03)
              dw = qq*ez*sp*xl
            end if
            ! ------- M-cell (itype = 3)
            if (itype(ncell)==3) dw = 0.
            ! ----    fringe field region (itype = 4)
            ! ********************************************
            if (itype(ncell)==4) dw = .5*qq*cay*avb*skz*sp*xl
            if (itype(ncell)==7) dw = 0.
            ! ********************************************
            ! --------RMS (itype = 5)
            if (itype(ncell)==5) then
              ez = -1./16.*a31vb*cay**3*rm*rm*(ckz-ckz3)*c2t
              dw = qq*ez*sp*xl
            end if
            ! --------RMS (itype = 6)
            if (itype(ncell)==6) then
              dw = 0.
            end if
            ! ----  WAV: energy at the middle of the element
            wav = ww + .5*dw
            ga = wav/er
            if (ga<=0.) then
              f(8, ip) = 0.
              ilost = ilost + 1
              ! needs to be on energy
              write (49, *) ' particle lost: ', i, ' W: ', wav, ' MeV'
              iflag = .true.
              go to 6525
            end if
            bgav = sqrt(ga*(2.+ga))
            gav = 1. + ga
            bav = bgav/gav
            ! ---- energy over step xl
            ww = ww + dw
            ga = ww/er
            gam = 1. + ga
            if (gam<=1.) then
              f(8, ip) = 0.
              ilost = ilost + 1
              ! needs to be on energy
              write (49, *) ' particle lost: ', i, ' W: ', ww, ' MeV'
              iflag = .true.
              go to 6525
            end if
            bg = sqrt(ga*(2.+ga))
            beta = sqrt(1.-1/(gam*gam))
            ! old jump of phase (sec) of particles (only for standard accelerating cells)
            delt = 0.
            ! old           if(itype(ncell).eq.0) then
            ! old             dez=.5*qq*cay*avb*skz*sp
            ! old             delt=.5*(dez/er) * xl*xl/(bav**3*gav**3*vlm)
            ! old           endif
            amort = bgi/bg
            bgfac = gav*bav**2
            cc = qq*xl*sp/(bgfac*er)
            ! ********************************************
            if (itype(ncell)/=4) then
              if (itype(ncell)==6) go to 9766
              if (itype(ncell)==7) go to 9766
              rr1 = cc*ex
              rr2 = cc*ey
9766          continue
              xpm = xpi*amort + rr1
              ypm = ypi*amort + rr2
              xf = xm + xpm*hl
              yf = ym + ypm*hl
            end if
            ! ********************************************
            ! ------- Fringe-field region (itype = 4)
            if (itype(ncell)==4) then
              ! *********************************************************
              ! C1 = (1/m**2) * (m) = (1/m)
              ! C2 = (1/m**2) * (m) = (1/m)
              ! RF1 = (MeV/(MeV*m**2)) = (1/m**2)
              ! RF2 =  (MeV/MeV) * (1/m**2) = (1/m**2)
              ! *******************************************************
              ! old              RF1=QQ*VORB/ER
              ! old              RF2=.25*QQ*CAY*CAY*AVB/ER
              ! old              C1=RF1*SP*XL/BGFAC
              ! old              C2=RF2*CKZ*SP*XL/BGFAC
              ! old              C1=C1*.75*(CKZ+C3KZ/3.)
              ! old              C2=C2*.75*(CKZ+3.*C3KZ)
              ! old              RR1=-(C1+C2)
              ! old              RR2=(C1-C2)
              ! rfq11(ncell) is (1.+avolt)*VV , where VV is intervane voltage seen by particles
              pavolt = rfq11(ncell)
              ! rfq9(ncell) is 1.+fvolt
              rpv = pavolt*rfq9(ncell)
              rf1 = qq*rpv/(r0*r0*er)
              ! avb is a10*rpv, but a10 is usually zero in fringe field
              rf2 = .25*qq*cay*cay*avb/er
              ! test cell parity
              ncf = (ipari(ncell)/2)*2 - ipari(ncell)
              if (ncf==0) then
                rf1 = -rf1
                rf2 = -rf2
              end if
              c1 = rf1*sp*xl/bgfac
              c2 = rf2*ckz*sp*xl/bgfac
              c1 = c1*.75*(ckz+c3kz/3.)
              c2 = c2*.75*(ckz+3.*c3kz)
              rr1 = -(c1+c2)
              rr2 = (c1-c2)
              xpm = xpi*amort + rr1*xm
              ypm = ypi*amort + rr2*ym
              xf = xm + xpm*hl
              yf = ym + ypm*hl
            end if
            ! restore coordinates x, xp, y, yp in cm and mrad
            f(2, ip) = xf*100.
            f(4, ip) = yf*100.
            f(3, ip) = xpm*1000.
            f(5, ip) = ypm*1000.
            ! tof over the length xl
            if (beta==0.) then
              f(6, ip) = f(6, ip) + hl/(bi*vlm)
            else
              f(6, ip) = f(6, ip) + hl/(bi*vlm) + hl/(beta*vlm)
            end if
            f(7, ip) = ww + er
6525        continue
            ! --- end do ip (particle loop)
          end do
          ! ----- reshuffle the good particles at the end of each element
          if (iflag) then
            call shuffle
            iflag = .false.
          end if
          ! space charge at the middle of the cell
          if (n==nsm) then
            if (ichaes) then
              ! Space Charge
              iesp = .true.
              call cesp(scl)
              iesp = .false.
            end if
          end if
          ! --- change the reference over the half step hl
          tref = tref + hl/(bref*vlm)
          if (itvol) ttvols = tref
          vref = bref*vl
          z = z + hl
          ! print in file rfq_list1.phase RF in the middle of the cell
          if (n==ns/2) then
            phmil = tref*fh + phini
            phmil = phmil*180./pi
            write (89, 9735) ncell, z, phdep, phmil
9735        format (2x, i5, 3(2x,e12.5))
          end if
          ! Change  dp/p over the cell
          call disp
          ! end of do n=1,nsp1 (steps in cell)
        end do
9527    continue
        ! ----  c.o.g of the bunch at the output of the cell
        tcog = 0.
        ecog = 0.
        do i = 1, ngood
          tcog = tcog + f(6, i)
          ecog = ecog + f(7, i)
        end do
        tcog = tcog/float(ngood)
        ecog = ecog/float(ngood)
        gcog = ecog/er
        bcog = sqrt(1.-1./(gcog*gcog))
        wcog = ecog - er
        ! ---  window control relative to the energy of the c.o.g of the bunch
        ! ---- ifw = 0 ===> wdisp = dW/W
        ! ---- ifw = 1 ===> wdisp = dW (MeV)
        ! ----- convert wdisp in dp/p
        if (ifw==0 .or. ifw==10) then
          dispr = gcog*gcog*wdisp/(gcog*(gcog+1.))
        end if
        if (ifw==1 .or. ifw==11) then
          dispr = gcog*gcog*wdisp/(gcog*(gcog+1.)*wcog)
        end if
        iflag = .false.
        do i = 1, ngood
          dese = abs(fd(i)-1.)
          if (dese>dispr) then
            ilost = ilost + 1
            f(8, i) = 0.
            write (49, *) ' particle lost: ', i, ' dp/p: ', dese, ' window :', dispr
            iflag = .true.
          end if
        end do
        if (iflag) then
          call shuffle
          ! ----  c.o.g of the bunch after shuffle
          tcog = 0.
          ecog = 0.
          do i = 1, ngood
            tcog = tcog + f(6, i)
            ecog = ecog + f(7, i)
          end do
          tcog = tcog/float(ngood)
          ecog = ecog/float(ngood)
          gcog = ecog/er
          bcog = sqrt(1.-1./(gcog*gcog))
          wcog = ecog - er
        end if
        br0 = rfq7(ncell)*rfq7(ncell)
        bff = (1./er)*wavel*wavel*tdvolt/br0
        write (75, 5555) ncell, rfq1(ncell), rfq2(ncell), rfq6(ncell), rfq7(ncell), rfq8(ncell)
5555    format (3x, i5, 5(3x,e12.5))
        ! et2010s
        ! dphete,dav1(idav,16),dav1(idav,21) and dav1(idav,12) still to be assigned correct value
        dphete = 0.
        trfprt = fh*tref*180./pi
        tcgprt = fh*tcog*180./pi
        ! n2kp=int(tofprt/360.)
        ! tofprt=tofprt-float(n2kp)*360.
        ! if(tofprt.gt.180.) tofprt=tofprt-360.
        ! cavity number, transmission (%), synchronous phase (deg), time of flight (deg) (reference),
        ! COG relativistic beta (@ output), COG output energy (MeV), REF relativistic beta (@ output), REF output energy
        ! (MeV),
        ! horizontal emittance (mm.mrad, RMS normalized), vertical emittance (mm.mrad, RMS normalized),
        ! longitudinal emittance (RMS, ns.keV)
        trnsms = 100.*float(ngood)/float(imax)
        call cdg(1)
        encog = cog(1)
        gcog = encog/xmat
        bcog = sqrt(1.-1./(gcog*gcog))
        tcog = cog(3)
        call ext2d(1)
        surxth = sqrt(exten(4)*exten(5)-exten(8)**2)
        suryph = sqrt(exten(6)*exten(7)-exten(9)**2)
        sqmdv = sqrt(exten(1)*exten(3)-exten(2)*exten(2))
        exns = bcog*surxth*10./sqrt(1.-bcog*bcog)
        eyns = bcog*suryph*10./sqrt(1.-bcog*bcog)
        emns = sqmdv*1.e12/fh
        if (ncell==1) then
          write (50, *) '# rfqparm.dmp'
          write (50, *) '# cell    Z       trans   ', 'PHIs     TOF(COG)    COG        Wcog          TOF(REF)   ', &
            '    REF        Wref       Ex,RMS,n     Ey,RMS,n     El,RMS'
          write (50, *) '#  #     (m)       (%)    ', '(deg)     (deg)      beta       (MeV)          (deg)      ', &
            '   beta       (MeV)      (mm.mrad)    (mm.mrad)    (ns.keV)'
        end if
        write (50, 7023) ncell, rfqdmp(ncell, 1), trnsms, rfqdmp(ncell, 2), tcgprt, bcog, wcog, trfprt, bref, wref, &
          exns, eyns, emns
7023    format (1x, i4, 1x, e12.5, 1x, f6.2, 1x, f7.2, 1x, 2(e14.7,1x,f7.5,1x,e14.7,1x), 3(e12.5,1x))
        if (ncell==nceltot) then
          write (16, 179)
179       format (/, ' Dynamics at the output', /, 5x, '   BETA     GAMMA      ENERGY(MeV) ', &
            '       TOF(deg)     TOF(sec)')
          write (16, 1788) bcog, gcog, wcog, tcog*fh*180./pi, tcog
          write (16, 165) bref, gref, wref, tref*fh*180./pi, tref
          if (itvol) write (16, *) '  time of flight: ', ttvols*fh*180./pi, ' deg'
          ! ----  new magnetic rigidity of the reference
          xmor = xmat*bref*gref
          boro = 33.356*xmor*1.e-01/qst
          dav1(idav, 4) = davtot*10.
          dav1(idav, 5) = xlrfq*10.
          dav1(idav, 6) = (gref-1.)*er
          dav1(idav, 36) = ngood
          irfqp = .false.
        end if
        ! plots
        call stapl(davtot*10.)
        ! --- end do ncell
      end do
      call emiprt(0)
      ! v28/04/2015
      ifcont = .false.
      write (16, *) 'After RFQ, bunched beam assumed'
      return
    end subroutine rfq_parm
    ! *******************************************************************
    ! SUBROUTINE stripp
    ! --- solid stripper foils for 'slow' hadron particles
    ! *******************************************************************
    subroutine stripp
      implicit real *8(a-h, o-z)
      parameter(iptsz=100002, maxcell=3000, maxcell1=3000)
      common /spl/x(4000), y(4000), s(5000), p(5000), q(5000)
      common /strip/atm, qs, atms, ths, qop, sqst(6), anp, nqst
      common /mcs/imcs, ncstat, cstat(20)
      common /davcom/dav1(maxcell1, 40), davtot, iitem(maxcell1), idav
      common /pltprf/sprfx(3000), sprfy(3000), sprfl(3000), sprfw(3000), sprfp(3000), sprng(3000), iprf
      common /consta/vl, pi, xmat, rpel, qst
      common /qmoyen/qmoy
      common /rigid/boro
      common /faisc/f(10, iptsz), imax, ngood
      dimension pc(20), npcent(20)
      common /cgtof/charm(20), cgtdv(20), nbch(20), netac
      ! dimension charge(6),pcent(6),charm(6),pc(6),eoff(6)
      character *1 cr
      dimension xeast(21), yeast(21), vecx(1)
      ! --- Eastham curve (reduced half angle over reduced thickness)
      ! ---- xeast: reduced thickness
      ! ---- yeast: reduced half angle
      data xeast/0.0, 2.0, 4.0, 6.0, 8.0, 10.0, 12.0, 14.0, 16.0, 18.0, 20.0, 22.0, 24.0, 26.0, 28.0, 30.0, 32.0, 34.0, &
        36.0, 38.0, 40.0/
      data yeast/0.00, 0.60, 1.04, 1.56, 1.80, 2.08, 2.32, 2.72, 2.96, 3.20, 3.44, 3.624, 3.808, 3.992, 4.176, 4.360, &
        4.544, 4.728, 4.912, 5.096, 5.28/
      ! ---- characteristics of the stripper:
      ! ---- qs : atomic number
      ! ---- atms   : Atomic mass (amu)
      ! ---- ths:thickness (g/cm**2)
      ! allow for print out on terminal of stripper number on one and the same line
      cr = char(13)
      nstrp = 1
      imcs = 1
      write (6, 8254) nrtre, nstrp, cr
8254  format ('Transport element:', i5, '      Charge Stripper     :', i5, a1, $)
      write (16, 101) anp, atm
101   format ('***** Projectile ', /, 4x, 'atomic number: ', f4.0, ' atomic mass : ', f4.0)
      write (16, 100) qs, atms, ths
100   format ('***** Charge Stripper ', /, 4x, 'atomic number: ', f4.0, ' atomic mass : ', f4.0, ' thickness: ', e12.5, &
        ' g/cm**2')
      ! ---- characteristics of particles
      ! --------- qp=f(9,i)
      ! --------- uem: atomic mass (amu)
      ! --------- wp=f(7,i)-xmat
      ! ----------------------------
      ! ----      ENVELOPE
      if (iprf==1) call stapl(davtot*10.)
      ! ---- start prints in file 'short.data'
      idav = idav + 1
      iitem(idav) = 16
      dav1(idav, 1) = qs
      dav1(idav, 2) = atms
      dav1(idav, 3) = ths
      dav1(idav, 4) = davtot*10.
      ! ---- kinetic energy at the input
      wicg = 0.
      do i = 1, ngood
        wicg = f(7, i) + wicg
      end do
      wicg = wicg/float(ngood)
      gcog = wicg/xmat
      bcog = sqrt(gcog*gcog-1.)/gcog
      wicg = wicg - xmat
      np = 21
      denes = 0.
      do i = 1, np
        x(i) = xeast(i)
        y(i) = yeast(i)
      end do
      ! ----  deriv2: develop the matrix for the b-splines functions
      call deriv2(np)
      len = 1
      do ip = 1, ngood
        wp = f(7, ip) - xmat
        ! --- wpatm: MeV/atm
        wpatm = wp/atm
        qp = f(9, ip)
        ! ---- xa: screening distance (cm)
        qsp = qs**(2./3) + qp**(2./3)
        xa = 4.68165e-9/sqrt(qsp)
        ! ---- reduced thickness: thck
        xn = 6.022e23/atms
        thck = xn*pi*xa*xa*ths
        ! --- reduce half angle: rtheta(rad) from Eastham curve
        ! ----  b-splines interpollation if thck<40, otherwise: rthet = 9.2e-02*thck + 1.6 (linear interpolation)
        if (thck<40.) then
          rthet = spline(np, thck)
        else
          rthet = 9.2e-02*thck + 1.6
        end if
        ! ---- half angle of diffusion: dthet (mrad)
        zps = qs*qp/(xa*wp)
        dthet = 2.88e-10*zps*rthet
        ! ---  angle of diffusion (mrad) scattered from M.C. separatly in xp and yp directions from a uniform law
        ! unif         call rlux(vec,len)
        ! unif         rx=(2.*vec-1.)*dthet*2.
        ! unif         f(3,ip)=f(3,ip)+rx
        ! unif         call rlux(vec,len)
        ! unif         ry=(2.*vec-1.)*dthet*2.
        ! unif         f(5,ip)=f(5,ip)+ry
        ! ---  angle of diffusion (mrad) scattered from M.C. separatly in xp and yp directions from a Gaussian law
        ax = f(3, ip)
        sm = dthet*2.
        call randga(len, sm, ax, vx)
        f(3, ip) = vx
        ay = f(5, ip)
        call randga(len, sm, ay, vy)
        f(5, ip) = vy
        ! ---  closest distance of approach: xb(cm)
        aps = (atms+atm)/(atms*atm)
        xb = 1.44e-13*aps*qs*qp/sqrt(wpatm)
        if (ip==1) then
          alpha = 1.576e-02*qp*qs/sqrt(wpatm)
          write (16, 5830) xa, thck, rthet, xb, dthet, alpha
5830      format (4x, 'screening distance: ', e12.5, ' cm', /, 4x, 'reduced thickness: ', e12.5, &
            ' reduced half angle: ', e12.5, ' rad ', /, 4x, 'closest distance of approach: ', e12.5, ' cm', /, 4x, &
            'half angle of diffusion: ', e12.5, ' mrad', /, 4x, 'Bohr parameter: ', e12.5)
        end if
        ! ----  loss of energy per scatter in the stripper (eq.16)
        wapc = 4.*atm*atms/((atm+atms)**2)
        dene = wapc*xb*xb*rthet*rthet/(xa*xa)*wp
        denes = denes + dene
        f(7, ip) = f(7, ip) - dene
        ! ---- change the electric charge state of the particle over the foil
        f(9, ip) = qop
      end do
      denes = denes/float(ngood)
      write (16, *) 'dE(MeV) (Eastham): ', dene, denes
      if (qs==6. .or. qs==3.) then
        ! ---- change the electric charge state of the particles (carbon foil case)
        ! ---- Based on E.Baron et al, NIM A328 (1993) p.177-182
        ! calculate dX', dY', dZ'
        fksi = 0.1535375*(qs/atms)*anp*ths/(bcog*bcog)
        des = 0.5*0.001*(1.866+1.57*log(wicg/atm))*(anp/atm)
        des = des*sqrt(1000000.*ths*qs/atms)
        write (16, *) 'dE(MeV) stripping: ', des, des*atm, wicg, wicg/atm
        write (16, *) 'dE(MeV) ksi: ', fksi
        ! calculate the charge state distribution
        qbar = anp*(1.-exp(-83.275*bcog/(anp**0.447)))
        qavg = qbar*(1.-exp(-12.905+0.2124*anp-0.00122*anp*anp))
        yy = qbar/anp
        stdv = sqrt(qbar*(0.07535+0.19*yy-0.2654*yy*yy))
        con = 1./(stdv*sqrt(2.*pi))
        fact = -1./(2.*stdv*stdv)
        pcsum = 0.
        numchs = 0
        qst = int(qavg)
        ! ---- only take charge states that have more than thresh % of the particles
        thresh = 100./float(ngood)
        write (16, 7830) thresh
7830    format (4x, 'Carbon foil stripper. Charge state distribution', &
          ' based on E.Baron et al, NIM A328 (1993) p.177-182', /, 4x, 'Threshhold for cutoff of the distribution: ', &
          f12.7, ' %')
        do i = 1, 100
          ! pc(i)=100.*con*exp(fact*(sqst(i)-qavg)*(sqst(i)-qavg))
          pcent = 100.*con*exp(fact*(float(i)-qavg)*(float(i)-qavg))
          if (pcent>thresh) then
            numchs = numchs + 1
            sqst(numchs) = float(i)
            pc(numchs) = pcent
            pcsum = pcsum + pcent
          end if
        end do
        nqst = numchs
        f(9, 1) = float(int(qavg))
        qavg = f(9, 1)
        write (16, 111) nqst, int(qavg)
        netac = nqst
111     format (4x, 'Number of charge states after the foil ', i2, /, 4x, 'Average charge state: ', i3)
        ! FIRST TRAJECTORY HAS AVERAGE CHARGE STATE
        ntot = 0
        do i = 1, numchs
          npcent(i) = int(pc(i)*float(ngood)/100.)
          ntot = ntot + npcent(i)
        end do
        ! *temp*2012 : before correction
        do i = 1, numchs
          write (16, 122) sqst(i), npcent(i), pc(i)
        end do
        ! add missing number of particles to central charge state
        ncstat = numchs
        write (16, *) '   ntot,ngood=', ntot, ngood, ' particles'
        do i = 1, numchs
          if (int(sqst(i))==int(f(9,1))) then
            npcent(i) = npcent(i) + ngood - ntot
          end if
          cstat(i) = float(int(sqst(i)))
          charm(i) = cstat(i)
          write (16, 122) sqst(i), npcent(i), pc(i)
        end do
122     format (4x, 'Charge=', f3.0, ' with ', i5, ' particles', ' or ', f12.7, ' %')
        len = 1
        i = 2
        do
          if (i>ngood) exit
          do
            call rlux(vecx, len)
            xarpha = vecx(1)
            ncount = int(xarpha*(float(numchs)+0.5))
            if (ncount>0) exit
          end do
          if (npcent(ncount)>0) then
            npcent(ncount) = npcent(ncount) - 1
            f(9, i) = float(int(sqst(ncount)))
            i = i + 1
          end if
        end do
      end if
      call cogetc
      ! ----  Change  dp/p over the stripper
      call disp

      ! ----  the new reference is the cog
      qcg = 0.
      wcg = 0.
      do i = 1, ngood
        wcg = f(7, i) + wcg
        qcg = f(9, i) + qcg
      end do
      wcg = wcg/float(ngood)
      gcg = wcg/xmat
      qcg = qcg/float(ngood)
      qmoy = qcg
      bref = sqrt(gcg*gcg-1.)/gcg
      vref = bref*vl
      ! ----  new magnetic rigidity
      xmor = xmat*bref*gcg
      boro = 33.356*xmor*1.e-01/qcg
      diff = (wcg-xmat) - wicg
      dav1(idav, 5) = qavg
      dav1(idav, 6) = diff
      dav1(idav, 36) = ngood
      write (16, 5420) wicg, -diff
5420  format (4x, 'energy of cog: at entrance: ', e12.5, ' MeV', /, 4x, 'energy loss of cog: ', e12.5, ' MeV')
      ! plots
      call stapl(davtot*10.)
      call emiprt(0)
      return
    end subroutine stripp
    subroutine randga(len, s, am, v)
      ! generateur aleatoire selon une loi normale
      ! s : ecart-type de la distribution
      ! am: moyenne de la distribution
      ! v : nombre aléatoire selon la loi normale
      implicit real *8(a-h, o-z)
      dimension vecx(1)

      a = 0.
      do i = 1, 24
        call rlux(vecx, len)
        y = vecx(1)
        a = a + y
      end do
      v = (a-12.)*s + am
      return
    end subroutine randga
    ! *******************************************************************
    ! SUBROUTINE qelec(volt,xlqua,rs)
    ! electrostatic quadrupole
    ! space charge computation at the middle of the lens
    ! VOLT: electric voltage at pole tip (kV)
    ! XLQUA: effective length  (cm)
    ! RS: radial distance of pole tip from axis (cm)
    ! *******************************************************************
    subroutine qelec(volt, xlqua, rs)
      implicit real *8(a-h, o-z)
      parameter(iptsz=100002, maxcell=3000, maxcell1=3000)
      common /fene/wdisp, wphas, wx, wy, rlim, ifw
      common /ttfc/tk, t1k, t2k, sk, s1k, s2k, fh
      common /dyn/tref, vref
      common /consta/vl, pi, xmat, rpel, qst
      common /rigid/boro
      common /faisc/f(10, iptsz), imax, ngood
      common /etcom/cog(8), exten(17), fd(iptsz)
      common /qmoyen/qmoy
      common /dcspa/iesp
      logical iesp
      common /sc3/beamc, scdist, sce10, cplm, ect, apl, ichaes, iscsp
      logical ichaes
      common /tapes/in, ifile, meta
      common /pltprf/sprfx(3000), sprfy(3000), sprfl(3000), sprfw(3000), sprfp(3000), sprng(3000), iprf
      common /davcom/dav1(maxcell1, 40), davtot, iitem(maxcell1), idav
      common /shif/dtiph, shift
      logical shift
      common /compt/nrres, nrtre, nrbunc, nrdbun
      common /rander/ialin
      logical ialin
      common /qskew/qtwist, iqrand, itwist, iaqu
      logical itwist
      common /femt/iemgrw, iemqesg
      logical iemgrw
      common /cgtof/charm(20), cgtdv(20), nbch(20), netac
      common /qsex/l, kq2, ks2
      common /tofev/ttvols
      common /itvole/itvol, imamin
      logical itvol, imamin
      real *8 l, kq2, ks2
      dimension trans(1)
      character *1 cr

      ilost = 0
      ! statistics
      if (iprf==1) call stapl(davtot*10.)
      write (16, *) ' ***QUADRUPOLE (electrostatic)***'
      write (16, *)
      fcpi = fh*180./pi
      if (itvol) write (16, 10) ttvols*fcpi, davtot
10    format (' ** tof for adjustments at input: ', e12.5, ' deg at position: ', e12.5, ' cm in lattice')
      ! print out on terminal of transport element # on one and the same line
      nrtre = nrtre + 1
      cr = char(13)
      write (6, 8254) nrtre, nrres, cr
8254  format ('Transport element:', i5, '      Accelerating element:', i5, a1, $)
      ! if itwist=.true. skews the quadrupole before misalignments (only if abs(volt) gt 1.e-13)
      ! len = 1 level 1 in rlux routine
      len = 1
      sqtwist = 0.
      if (abs(volt)>1.e-13) then
        if (itwist) then
          if (iqrand==0) then
            qtwrad = qtwist
            sqtwist = qtwrad
            call zrotat(qtwrad)
          else
            rdcf = .5
            call rlux(trans, len)
            if (trans(1)<=rdcf) sign = -1.
            if (trans(1)>rdcf) sign = 1.
            call rlux(trans, len)
            qtwrad = qtwist*sign*trans(1)
            sqtwist = qtwrad
            call zrotat(qtwrad)
          end if
        end if
        ! misalignments
        if (ialin) call randali
      end if
      idav = idav + 1
      iitem(idav) = 18
      dav1(idav, 1) = xlqua*10.
      davtot = davtot + xlqua
      dav1(idav, 4) = davtot*10.
      fh0 = fh/vl
      gpa = 0.
      do ii = 1, ngood
        gpa = gpa + f(7, ii)/xmat
      end do
      gpa = gpa/float(ngood)
      bet = sqrt(gpa*gpa-1.)/gpa
      l = xlqua
      eni = gpa*xmat
      qi = qst
      ! electric rigidity (kV)
      rigid = eni*bet*bet/qi*1.e03
      ! electric field gradient: xgrad (kV/cm-2)
      xgrad = 2.*volt/rs**2
      dav1(idav, 2) = volt
      dav1(idav, 3) = rigid
      dav1(idav, 5) = xgrad
      ! qk2 (cm-2)
      kq2 = xgrad/rigid
      dav1(idav, 6) = kq2
      dav1(idav, 7) = rs*10.
      write (16, 100) xlqua, rs, volt, kq2, xgrad, rigid
100   format (' LENGTH = ', e12.5, ' cm   APERTURE RADIUS= ', e12.5, ' cm', /, ' VOLTAGE = ', e12.5, ' kV  K2 = ', &
        e12.5, ' cm-2  GRADIENT = ', e12.5, ' kV/cm2', /, ' RIGIDITY = ', e12.5, ' kV', /)
      call clear
      call elqua
      ! print out the transport matrix (cog)
      call matrix
      ! first half quadrupole
      l = xlqua/2.
      do ii = 1, ngood
        call clear
        gpa = f(7, ii)/xmat
        bet = sqrt(gpa*gpa-1.)/gpa
        qi = f(9, ii)
        ! electric rigidity (kV)
        rigi = f(7, ii)*bet*bet/qi*1.e03
        ! qk2 (cm-2)
        kq2 = xgrad/rigi
        call elqua
        call cobeam(ii, l)
      end do
      ! space charge computations (if l >0)
      if (ichaes .and. l>0.) then
        if (sce10==1 .or. sce10==3.) then
          iesp = .true.
          write (16, *) 'space charge at the middle of the lens'
          call cesp(xlqua)
          iesp = .false.
          ! Change the dispersion dE/E with respect to the C.O.G of the bunch
          call disp
        end if
      end if
      ! Test window after the first half quadrupole (after s.c. computations)
      call cogetc
      bcour = 0.
      do i = 1, ngood
        gpai = f(7, i)/xmat
        bcour = sqrt(1.-1./(gpai*gpai)) + bcour
      end do
      bcour = bcour/float(ngood)
      gcour = 1./sqrt(1.-bcour*bcour)
      wcg = (gcour-1.)*xmat
      ! ----- window control
      tref = tref + xlqua/(2.*vref)
      call reject(nlost)
      ! Reshuffles f(i,j) array after window (now done in 'reject')
      ! call shuffle
      ! second half quadrupole
      do ii = 1, ngood
        call clear
        gpa = f(7, ii)/xmat
        bet = sqrt(gpa*gpa-1.)/gpa
        qi = f(9, ii)
        rigi = f(7, ii)*bet*bet/qi*1.e03
        kq2 = xgrad/rigi
        call elqua
        call cobeam(ii, l)
      end do
      ! Test window after the second half quadrupole
      call cogetc
      tref = tref + xlqua/(2.*vref)
      call reject(ilost)
      ilost = ilost + nlost
      ! Reshuffles f(i,j) array after window (now done in 'reject')
      ! call shuffle
      ! Change the t.o.f
      if (itvol) ttvols = tref
      ! envelope
      call stapl(davtot*10.)
      tcog = 0.
      do i = 1, ngood
        tcog = tcog + f(6, i)
      end do
      tcog = tcog/float(ngood)
      if (itvol) then
        write (16, 11) ttvols*fcpi, davtot, tref*fcpi, tcog*fcpi
11      format (' ** tof for adjustments: ', e12.5, ' deg at position: ', e12.5, ' cm in the lattice', /, 3x, &
          'tof of the reference: ', e12.5, ' deg tof of the cog: ', e12.5, ' deg')
      else
        write (16, 12) tref*fcpi, tcog*fcpi
12      format (' ** tof of the reference: ', e12.5, ' deg tof of the cog: ', e12.5, ' deg')
      end if
      dav1(idav, 36) = ngood
      write (16, *) ' particles lost :', ilost
      ! returns coordinates to the initial orientation
      if (itwist) then
        if (abs(volt)>1.e-13) then
          qtwrad = -sqtwist
          call zrotat(qtwrad)
        end if
      end if
      if (iemgrw) call emiprt(0)
      ! envelope
      call stapl(davtot*10.)
      return
    end subroutine qelec
    ! *******************************************************************
    ! SUBROUTINE qfk (ityqu,arg,xlqua,rs)
    ! electrostatic or magnetic quadrupole based on the strength K2
    ! space charge computation at the middle of the lens
    ! ITYQU: ITYQU = 0 electric quadrupole, otherwise magnetic
    ! quadrupole
    ! ARG: strength K (cm-2)
    ! XLQUA: effective length  (cm)
    ! RS: radial distance of pole tip from the axis (cm)
    ! *******************************************************************
    subroutine qfk(ityqu, arg, xlqua, rs)
      implicit real *8(a-h, o-z)
      parameter(iptsz=100002, maxcell=3000, maxcell1=3000)
      common /fene/wdisp, wphas, wx, wy, rlim, ifw
      common /ttfc/tk, t1k, t2k, sk, s1k, s2k, fh
      common /dyn/tref, vref
      common /consta/vl, pi, xmat, rpel, qst
      common /rigid/boro
      common /faisc/f(10, iptsz), imax, ngood
      common /etcom/cog(8), exten(17), fd(iptsz)
      common /qmoyen/qmoy
      common /dcspa/iesp
      logical iesp
      common /sc3/beamc, scdist, sce10, cplm, ect, apl, ichaes, iscsp
      logical ichaes
      common /tapes/in, ifile, meta
      common /pltprf/sprfx(3000), sprfy(3000), sprfl(3000), sprfw(3000), sprfp(3000), sprng(3000), iprf
      common /davcom/dav1(maxcell1, 40), davtot, iitem(maxcell1), idav
      common /shif/dtiph, shift
      logical shift
      common /compt/nrres, nrtre, nrbunc, nrdbun
      common /rander/ialin
      logical ialin
      common /qskew/qtwist, iqrand, itwist, iaqu
      logical itwist
      common /femt/iemgrw, iemqesg
      logical iemgrw
      common /cgtof/charm(20), cgtdv(20), nbch(20), netac
      common /qsex/l, kq2, ks2
      common /tofev/ttvols
      common /itvole/itvol, imamin
      common /qfkd/ityq
      logical itvol, imamin, ityq
      real *8 l, kq2, ks2
      dimension trans(1)
      character *1 cr

      ilost = 0
      if (ityqu==0) ityq = .true.
      if (ityqu/=0) ityq = .false.
      if (ityq) then
        write (16, *) ' ***QUADRUPOLE (electrostatic)***'
      else
        write (16, *) ' ***QUADRUPOLE (magnetic)***'
      end if
      ! statistics
      if (iprf==1) call stapl(davtot*10.)
      xfqu = arg
      fcpi = fh*180./pi
      if (itvol) write (16, 10) ttvols*fcpi, davtot
10    format (' ** tof at input: ', e12.5, ' deg  position in the lattice: ', e12.5, ' cm ')
      ! print out on terminal of transport element # on one and the same line
      nrtre = nrtre + 1
      cr = char(13)
      write (6, 8254) nrtre, nrres, cr
8254  format ('Transport element:', i5, '      Accelerating element:', i5, a1, $)
      ! if itwist=.true. skews the quadrupole before misalignments (only if abs(arg) gt 1.e-13)
      ! len = 1 level 1 in rlux routine
      len = 1
      sqtwist = 0.
      if (abs(xfqu)>1.e-13) then
        if (itwist) then
          if (iqrand==0) then
            qtwrad = qtwist
            sqtwist = qtwrad
            call zrotat(qtwrad)
          else
            rdcf = .5
            call rlux(trans, len)
            if (trans(1)<=rdcf) sign = -1.
            if (trans(1)>rdcf) sign = 1.
            call rlux(trans, len)
            qtwrad = qtwist*sign*trans(1)
            sqtwist = qtwrad
            call zrotat(qtwrad)
          end if
        end if
        ! misalignments
        if (ialin) call randali
      end if
      idav = idav + 1
      iitem(idav) = 19
      dav1(idav, 1) = xlqua*10.
      davtot = davtot + xlqua
      dav1(idav, 4) = davtot*10.
      fh0 = fh/vl
      gpa = 0.
      do ii = 1, ngood
        gpa = gpa + f(7, ii)/xmat
      end do
      gpa = gpa/float(ngood)
      bet = sqrt(gpa*gpa-1.)/gpa
      l = xlqua
      eni = gpa*xmat
      qi = qst
      ! electric quadrupole
      if (ityq) then
        ! rigid: electric momentum (kV)
        rigid = eni*bet*bet/qi*1.e03
        ! compute the electric voltage VOLT (kV) from K(cm-2)
        volt = xfqu*rs*rs*rigid
        volt = volt/2.
        ! kq2 (cm-2)
        kq2 = xfqu
        ! electric field gradient: xgrad (kV/cm2)
        xgrad = kq2*rigid
        dav1(idav, 2) = volt
        dav1(idav, 3) = rigid
        dav1(idav, 5) = xgrad
        dav1(idav, 6) = xfqu
        dav1(idav, 7) = rs*10.
        call clear
        call elqua
        write (16, 100) xlqua, rs, volt, xfqu, xgrad, rigid
100     format (' LENGTH = ', e12.5, ' cm   APERTURE RADIUS= ', e12.5, ' cm', /, ' VOLTAGE = ', e12.5, ' kV  K2 = ', &
          e12.5, ' cm-2  GRADIENT = ', e12.5, ' kV/cm2', /, ' MOMENTUM = ', e12.5, ' kV', /)
        ! print the transport matrix (of the cog)
        call matrix
      end if
      ! magnetic quadrupole
      if (.not. ityq) then
        xmco = xmat*bet*gpa
        ! rigid: magnetic rigidity (kG.cm)
        rigid = 33.356*xmco*1.e-01/qst
        kq2 = xfqu
        ! bgrad: gradient (kG/cm)
        bgrad = kq2*rigid
        ! bgaus: field (kG)
        bgaus = bgrad*rs
        dav1(idav, 2) = bgaus
        dav1(idav, 3) = rigid
        dav1(idav, 5) = bgrad
        dav1(idav, 6) = xfqu
        dav1(idav, 7) = rs*10.
        call clear
        call elqua
        write (16, 3300) xlqua, rs, bgaus, xfqu, bgrad, rigid
3300    format (' LENGTH = ', e12.5, ' cm   APERTURE RADIUS= ', e12.5, ' cm', /, ' FIELD = ', e12.5, ' kG  K2 = ', &
          e12.5, ' cm-2  GRADIENT = ', e12.5, ' kG/cm', /, ' MOMENTUM = ', e12.5, ' kG.cm', /)
        call matrix
      end if
      ! first half quadrupole
      l = xlqua/2.
      do ii = 1, ngood
        call clear
        gpa = f(7, ii)/xmat
        bet = sqrt(gpa*gpa-1.)/gpa
        qi = f(9, ii)
        ! electric quadrupole
        if (ityq) then
          ! rigi: momentum (kV)
          rigi = f(7, ii)*bet*bet/qi*1.e03
          ! qk2 (cm-2)
          kq2 = xgrad/rigi
          call elqua
          call cobeam(ii, l)
        end if
        ! magnetic quadrupole
        if (.not. ityq) then
          xmco = xmat*bet*gpa
          ! rigi: momentum (kG.cm)
          rigi = 3.3356*xmco/f(9, ii)
          ! kq2 (cm-2)
          kq2 = bgrad/rigi
          call elqua
          call cobeam(ii, l)
        end if
      end do
      ! space charge computations (if l >0)
      if (ichaes .and. l>0.) then
        if (sce10==1 .or. sce10==3.) then
          iesp = .true.
          write (16, *) 'space charge at the middle  '
          call cesp(xlqua)
          iesp = .false.
          ! Change the dispersion dE/E with respect to the C.O.G of the bunch
          call disp
        end if
      end if
      ! Test window after the first half quadrupole (after s.c. computations)
      call cogetc
      bcour = 0.
      do i = 1, ngood
        gpai = f(7, i)/xmat
        bcour = sqrt(1.-1./(gpai*gpai)) + bcour
      end do
      bcour = bcour/float(ngood)
      gcour = 1./sqrt(1.-bcour*bcour)
      wcg = (gcour-1.)*xmat
      ! ----- convert window control
      tref = tref + xlqua/(2.*vref)
      call reject(nlost)
      ! Reshuffles f(i,j) array after window (now done in 'reject')
      ! call shuffle
      ! second half quadrupole
      do ii = 1, ngood
        call clear
        gpa = f(7, ii)/xmat
        bet = sqrt(gpa*gpa-1.)/gpa
        qi = f(9, ii)
        ! electric quadrupole
        if (ityq) then
          ! rigi (kV)
          rigi = f(7, ii)*bet*bet/qi*1.e03
          ! qk2 (cm-2)
          kq2 = xgrad/rigi
          call elqua
          call cobeam(ii, l)
        end if
        ! magnetic quadrupole
        if (.not. ityq) then
          xmco = xmat*bet*gpa
          ! rigi: momentum (kG.cm)
          rigi = 3.3356*xmco/f(9, ii)
          ! kq2 (cm-2)
          kq2 = bgrad/rigi
          call elqua
          call cobeam(ii, l)
        end if
      end do
      ! Test window after the second half quadrupole
      call cogetc
      tref = tref + xlqua/(2.*vref)
      call reject(ilost)
      ilost = ilost + nlost
      ! Reshuffles f(i,j) array after window (now done in 'reject')
      ! call shuffle
      ! Change the t.o.f
      if (itvol) ttvols = tref
      ! envelope
      call stapl(davtot*10.)
      tcog = 0.
      do i = 1, ngood
        tcog = tcog + f(6, i)
      end do
      tcog = tcog/float(ngood)
      if (itvol) then
        write (16, 11) ttvols*fcpi, davtot, tref*fcpi, tcog*fcpi
11      format (' ** tof for adjustments: ', e12.5, ' deg at position: ', e12.5, ' cm in the lattice', /, 3x, &
          'tof of the reference: ', e12.5, ' deg tof of the cog: ', e12.5, ' deg')
      else
        write (16, 12) tref*fcpi, tcog*fcpi
12      format (' ** tof of the reference: ', e12.5, ' deg tof of the cog: ', e12.5, ' deg')
      end if
      dav1(idav, 36) = ngood
      write (16, *) ' particles lost :', ilost
      ! returns coordinates to the initial orientation
      if (itwist) then
        if (abs(xfqu)>1.e-13) then
          qtwrad = -sqtwist
          call zrotat(qtwrad)
        end if
      end if
      if (iemgrw) call emiprt(0)
      ! envelope
      call stapl(davtot*10.)
      return
    end subroutine qfk
    ! *******************************************************************
    ! SUBROUTINE cavnum
    ! numerical computations of the dynamic in cavities or gap
    ! the field can be read on the disk on the form: (z,E(z)
    ! or it can be read in the command list on the form of a Fourier
    ! series expansion
    ! *******************************************************************
    subroutine cavnum
      implicit real *8(a-h, o-z)
      parameter(iptsz=100002, maxcell=3000, maxcell1=3000)
      common /ttfs/dynt(maxcell), dyntp(maxcell), dyntpp(maxcell), dyne0(maxcell), dynph(maxcell), dynlg(maxcell), &
        fhpar, nc
      common /posi/ist
      common /midgap/enmil, vapmi
      common /azmtch/dlg, xmcph, xmce
      common /azlist/icont, iprin
      common /itvole/itvol, imamin
      common /func/a(200), ylg, atte, ncel, nharm
      common /cgtof/charm(20), cgtdv(20), nbch(20), netac
      ! TRANSIT TIME COEFFICIENTS
      common /ttfc/tk, t1k, t2k, sk, s1k, s2k, fh
      common /faisc/f(10, iptsz), imax, ngood
      common /spl/xspl(4000), yspl(4000), s(5000), p(5000), q(5000)
      common /cavnum1/xnh, xpas, ffield, npt
      common /cavnum2/b0, b1, b2, b3, b4, b5
      common /cell/yf(10000), xf(10000), xlim(15), flength, fhc, att, npoint(15), ncell
      common /rfield/ifield
      common /qmoyen/qmoy
      common /rigid/boro
      common /sc3/beamc, scdist, sce10, cplm, ect, apl, ichaes, iscsp
      common /consta/vl, pi, xmat, rpel, qst
      common /dyn/tref, vref
      common /compt/nrres, nrtre, nrbunc, nrdbun
      common /compt1/ndtl, ncavmc, ncavnm
      common /fene/wdisp, wphas, wx, wy, rlim, ifw
      common /tapes/in, ifile, meta
      common /etcom/cog(8), exten(17), fd(iptsz)
      common /speda/dave, idave
      common /shif/dtiph, shift
      common /davcom/dav1(maxcell1, 40), davtot, iitem(maxcell1), idav
      common /etcha1/dav2(maxcell1, 33), ichas(iptsz), chasit
      common /dcspa/iesp
      common /pltprf/sprfx(3000), sprfy(3000), sprfl(3000), sprfw(3000), sprfp(3000), sprng(3000), iprf
      common /appel/irstay, ilost, iavp, ispcel
      common /femt/iemgrw, iemqesg
      common /mode/eflvl, rflvl
      common /aerp/vphase, vfield, ierpf
      common /tofev/ttvols
      common /elec/jelec
      common /step/istep
      ! ****************************************************************
      ! SV 09/09/2015
      common /xposi/xpost(10), xlce(2), xpax(2), iscx(2)
      common /kcell/avrg(15)
      ! ****************************************************************
      ! *ET*2015*Jul*S
      ! ********************************************
      ! reservation for TRACE3D related stuff
      common /trace3d/trace3h(100), trace3t(maxcell1), tif, kt3h, kt3t, fid
      common /t3dfld/fldctr(15), zend(15), t3d
      ! logical T3D,xiset
      logical t3d
      ! character*128 trace3h,trace3t,tif,tifa,tifb
      character *128 trace3h, trace3t, tif
      ! ********************************************
      common /xitrd3/bcour1(15), bcour2(15), tr3dw(15), tr3ph(15), t0tr3d(15)
      ! *ET*2015*Jul*E
      logical iesp, ichaes, irstay, iavp, ispcel, ifield, iemgrw
      logical shift, chasit, itvol, imamin, dave, jelec
      character *1 cr
      ! ************************************************************
      ! XESLN : NEGATIVE LENGHT OF THE DRIFT FOLLOWING THE GAP
      ! IF XESLN N.E.0 THEN THE CHARGE SPACE EFFECT IMPLIES THE
      ! LENGTH (YLG-XESLN)
      nrres = nrres + 1
      ncavnm = ncavnm + 1
      ! allow for print out on terminal of gap# on one and the same line
      cr = char(13)
      write (6, 8254) nrtre, nrres, cr
8254  format ('Transport element:', i5, '      Accelerating element:', i5, a1, $)
      write (16, *) ' CAVITY N :', nrres
      ilost = 0
      aqst = abs(qst)
      qmoy = aqst
      ! --- the frequency fh may be changed with delfh
      oldfh = fh
      ! IDUM : dummy variable (indicate in input file the number of the cavity)
      read (in, *) idum

      ! ielec = 0 acceleration for non relativistic particles with erest < 1 MeV (e.g. non-relativistic electrons)
      ! otherwise acceleration for hadrons
      ! dphase (deg): phase offset from the phase crest (giving the maximum of energy gain)
      ! FFIELD : in percent;
      ! (electric field)=(initial electric field)*(1.+FFIELD/100)
      jelec = .false.
      read (in, *) dielec, dphase, ffield, istep, ielec
      ! *********************************************************
      ! SV  28/10/2015
      if (ncavnm==1) write (13, 990)
990   format (3x, 'ncav', 2x, 'ncell', 2x, 'pos I(cm)', 4x, 'pos S(cm)', 6x, 'L cell(cm)', 5x, 'W(Mev)', 7x, 'dw(Mev)', &
        6x, 'TOF(dg)', 7x, 'Ph RF(dg)', 5x, 'avrg pos(cm)')
      if (ncavnm==1) write (13, 995)
995   format (3x, 'ncell', 3x, 'E0TL(Mev)', 4x, 'T(k) Mev/q', 4x, 'S(k) Mev/q', 5x, 'dW(Mev)', 6x, 'PHASE(dg)', 5x, &
        'Ph crest(dg)')
      write (13, *)
      ! ***************************************************************
      if (ielec==0) jelec = .true.
      ffield = 1. + ffield/100.
      if (ffield==0.) ffield = 1.e-12
      if (ifield) then
        ! --- The field is read on the disk in the form:
        ! z   (cm)   E(z) MV/cm
        ! fhc: frequency of the cavity (Hertz) (read in the file 'field.txt' )
        fh = fhc*2.*pi
        ncel = ncell
        atte = att
        ye0 = atte
        ! flength : length of the field (cm)
        flength = xspl(npt) - xspl(1)
        ylg = flength
      else
        ! --- The field is read on the input list in the form of a Fourier series
        ncell = ncel
        oldfh = fh
        ! atte: factor acting on the amplitude of the field (read in the input list)
        ye0 = atte
      end if
      dphete = dphase
      if (itvol .and. imamin) then
        ! ---  adjustment of the phase offset w.r.t. the t.o.f.  (deg)
        ottvol = fh*ttvols*180./pi
        attvol = ottvol
        xkpi = ottvol/360.
        ixkpi = int(xkpi)
        xkpi = (xkpi-float(ixkpi))*360.
        dphase = dphase - xkpi
      end if
      write (16, 150) fh/(2.*pi), ylg, atte, ffield, ncel, istep
150   format (4x, 'FREQUENCY :', e12.5, ' Hertz', /, 4x, 'FIELD LENGTH :', e12.5, ' cm', /, 4x, &
        'FIELD FACTOR (UNITS CONVERSION) :', e12.5, /, 4x, 'FIELD FACTOR (ATTENUATION)      :', e12.5, /, 4x, &
        'FIELD DIVIDED IN: ', i4, ' CELLS  STEPS BY CELL ', i5)
      if (.not. imamin) write (16, *) '   PHASE OFFSET: ', dphete, ' DEG'
      if (imamin) write (16, 1501) dphete, dphase, xkpi
1501  format (4x, 'PHASE OFFSET (before adjustment): ', e12.5, ' deg', /, 4x, 'PHASE OFFSET (after adjustment): ', &
        e12.5, ' deg', /, 4x, 'ADJUSTMENT ON THE PHASE OFFSET: ', e12.5, ' deg')
      fh0 = fh/vl
      beref = vref/vl
      ! --- ttvol: time of flight at entrance (sec)
      ttvol = 0.
      if (itvol) ttvol = ttvols*fh
      ! start file 'short.data'
      ! --- dav1(idav,3)=0: the particle reference and the cog coincide at the input
      ! --- dav1(idav,3)=1: the particle reference and the cog are independent
      dav1(idav, 3) = 0.
      idav = idav + 1
      iitem(idav) = 1
      dav1(idav, 1) = ylg*10.
      dav1(idav, 2) = ye0*100.
      davtot = davtot + ylg
      dav1(idav, 24) = davtot*10.
      dav1(idav, 40) = fh
      if (iprf==1) call stapl(dav1(idav,24))
      iarg = 1
      call cdg(iarg)
      enold = cog(1)
      encog = enold
      gcog = enold/xmat
      bcog = sqrt(1.-1./(gcog*gcog))
      tcog = cog(3)
      if (shift) then
        ! --- the reference particle and the cog are independent
        beref = vref/vl
        gamref = 1./sqrt(1.-(beref*beref))
        enref = xmat*gamref
        trefdg = tref*fh*180./pi
        dav1(idav, 3) = 1.
      else
        ! --- the reference particle and the cog are coinciding
        beref = bcog
        vref = bcog*vl
        tref = tcog
        gamref = gcog
        enref = cog(1)
        dav1(idav, 3) = 0.
      end if
      if (dav1(idav,3)==1.) write (16, *) ' ****reference and cog evolve independently'
      if (dav1(idav,3)==0.) write (16, *) ' **** the reference is the cog '
      write (16, 178)
178   format (/, ' Dynamics at the input', /, 5x, '   BETA     GAMMA      ENERGY(MeV) ', '       TOF(deg)     TOF(sec)')
      write (16, 1788) bcog, gcog, encog - xmat, tcog*fh*180./pi, tcog
1788  format (' COG ', f7.5, 3x, e12.5, 1x, e12.5, 3x, e12.5, 3x, e12.5)
      enrprin = enref - xmat
      write (16, 165) beref, gamref, enrprin, tref*fh*180./pi, tref
165   format (' REF ', f7.5, 3x, e12.5, 1x, e12.5, 3x, e12.5, 3x, e12.5)
      iprint = 0
      call statis
      xk1 = fh/vref
      ! ---  transit time factors TK and SK  based on the velocity at the entrance
      tk = tta0(beref)/2.*ffield
      sk = tsb0(beref)/2.*ffield
      ! --- prediction of PCREST (phase of RF giving the maximum of energy gain in the cavity)
      pcrest = atan(-sk/tk)
      ddwc = aqst*(tk*cos(pcrest)-sk*sin(pcrest))
      if (ddwc<0.) pcrest = pcrest + pi
      ! --- first correction of pcrest based on an average beta
      call phcrest(pcrest, ylg, ncell, zcrest)
      ! avbet: average value of beta
      avbet = fh/(zcrest*vl)
      tk = tta0(avbet)/2.*ffield
      sk = tsb0(avbet)/2.*ffield
      pcrest = atan(-sk/tk)
      ddwc = aqst*(tk*cos(pcrest)-sk*sin(pcrest))
      if (ddwc<0.) pcrest = pcrest + pi
      ! final correction of the phase crest PCREST
      call phcrest1(pcrest, ylg, ncell)
      ! phase at the entrance of the cavity
      dphase = dphase*pi/180.
      phi0 = pcrest + dphase + ttvol
      ! --- compute energy and TOF of reference
      ! ******************************************
      call dwref(phi0, gams, ts)
      ! ********************************************
      enrs = gams*xmat
      ddw = enrs - enref
      if (t3d) then
        do klm = 1, ncel

          trphase = tr3ph(klm)
          tre0tl = t0tr3d(klm)/aqst
          ! c split cell into drif-gap-drift
          ! c debugging to be done: include q/m !!! protons assumed for now
          kt3t = kt3t + 1
          ! drift
          write (tif, 6001) kt3t, kt3t, 10.*fldctr(klm)
6001      format ('  nt(', i4, ')= 1, a(1,', i4, ')=', f12.6)
          trace3t(kt3t) = tif

          kt3t = kt3t + 1
          ! gap
          write (tif, 6005) kt3t, kt3t, tre0tl, trphase, fid
6005      format ('  nt(', i4, ')=10, a(1,', i4, ')=', f9.5, ' , ', f9.2, ', 0., 1.,', f5.3, ',')
          trace3t(kt3t) = tif

          kt3t = kt3t + 1
          ! drift
          write (tif, 6001) kt3t, kt3t, 10.*zend(klm)
          trace3t(kt3t) = tif
        end do
      end if
      ! end trace3d drift-gap-drift

      trefs = ts + tref
      bets = sqrt(gams*gams-1.)/gams
      ! old       bets=b5
      tredg = fh*trefs*180./pi
      ! dynamic of the bunch
      call bcnum(phi0, ylg, ncell)
      ! -----  window control
      gcg = 0.
      do i = 1, ngood
        gcg = gcg + f(7, i)/xmat
      end do
      gcg = gcg/float(ngood)
      bcg = sqrt(1.-1./(gcg*gcg))
      wcg = (gcg-1.)*xmat
      call cogetc
      ! omment  twind=0.
      do i = 1, ngood
        gpai = f(7, i)/xmat
        if (gpai<1.) gpai = 1.
        bpai = sqrt(1.-1./(gpai*gpai))
        fd(i) = bpai/bcg*gpai/gcg
        ! omment    twind=twind+f(6,i)
      end do
      ! omment  twind=twind/float(ngood)
      ! ---- window control
      tref = trefs
      vref = bets*vl
      call reject(ilost)
      ! Reshuffles f(i,j) array after window (now done in 'reject')
      ! call shuffle
      write (16, *) ' PARAMETERS RELATING TO THE REFERENCE PARTICLE '
      write (16, *) '***********************************************'
      write (16, *) ' ENERGY GAIN(MeV) ', ddw, ' TOF ', tredg, ' DEG'
      write (16, *) ' PHASE OF RF AT ENTRANCE(DG) ', phi0*180./pi
      write (16, *) ' CREST PHASE OF RF (DEG) ', pcrest*180./pi
      iarg = 1
      call cdg(iarg)
      encog = cog(1)
      gcog = encog/xmat
      bcog = sqrt(1.-1./(gcog*gcog))
      tcog = cog(3)
      call ext2d(1)
      ! print in file 'short.data'
      ! 3.12.09       phnew=-(int(tcog*fh/pi+0.5)-tcog*fh/pi)*180.
      ! 3.12.09       dav1(idav,6)=encog-xmat
      ! 3.12.09        dav1(idav,7)=phnew
      if (itvol) then
        dav1(idav, 38) = dphete
        dav1(idav, 39) = dphase*180./pi
      else
        dav1(idav, 38) = dphete
      end if
      write (16, 3777)
3777  format (/, ' Dynamics at the output', /, 5x, '   BETA     dW(MeV)     ENERGY(MeV) ', '   TOF(deg)     TOF(sec)')
      engain = encog - enold
      write (16, 3473) bets, ddw, enrs - xmat, fh*trefs*180./pi, trefs
3473  format (' REF ', f7.5, 3x, f10.6, 3x, e12.5, 3x, e12.5, 3x, e12.5)
      write (16, 1789) bcog, engain, encog - xmat, tcog*fh*180./pi, tcog
1789  format (' COG ', f7.5, 3x, f10.6, 3x, e12.5, 3x, e12.5, 3x, e12.5)
      testca = exten(1)*exten(2)*exten(3)
      ! epsil=1.E-20
      epsil = 1.e-40
      if (abs(testca)>epsil) then
        qdisp = 2.*sqrt(exten(1))
        qmd = exten(1)*exten(3) - exten(2)**2
        sqmdv = 4.*pi*sqrt(qmd)
        surm = 4.*pi*sqrt(qmd)*180./pi
        qdp = 2.*sqrt(exten(3))
        cor12 = exten(2)/sqrt(exten(1)*exten(3))
        ! omment         PENT12=SQRT(exten(1)/exten(3))/COR12
        ! omment         PENT21=SQRT(exten(1)/exten(3))*COR12
        qdpde = qdp*180./pi
      else
        qdisp = 0.
        qmd = 0.
        sqmdv = 0.
        surm = 0.
        qdp = 0.
        cor12 = 0.
        pent12 = 0.
        pent21 = 0.
        qdpde = 0.
      end if
      trqtx = exten(4)*exten(5) - exten(8)**2
      trqpy = exten(6)*exten(7) - exten(9)**2
      qditax = 2.*sqrt(exten(4))
      qdiant = 2.*sqrt(exten(5))
      qditay = 2.*sqrt(exten(6))
      qdianp = 2.*sqrt(exten(7))
      surxth = 4.*pi*sqrt(trqtx)
      suryph = 4.*pi*sqrt(trqpy)
      if (shift) then
        vref = bets*vl
        tref = trefs
      else
        vref = bcog*vl
        tref = tcog
      end if
      if (itvol) ttvols = tref
      call statis
      ! ENVEL
      call stapl(dav1(idav,24))
      ! old       WRITE(16,9998) SQMDV
      ! old 9998   FORMAT(2X,'   EMITTANCE (norm): ',
      ! old     *        E12.5,' PI*MEV*RAD')
      dav1(idav, 16) = bcog*surxth*10./(pi*sqrt(1.-bcog*bcog))
      ! 3.12.09       dav1(idav,17)=surxth*10./pi

      dav1(idav, 21) = bcog*suryph*10./(pi*sqrt(1.-bcog*bcog))
      dav1(idav, 25) = nrres
      dav1(idav, 30) = ngood

      ! print in the file: 'dynac.dmp':
      ! gap number, phase offset(deg), relativistic beta, energy(MeV), horz. emit.(mm*mrd,norm), vert.
      ! emit.(mm*mrd,norm),long. emit(keV*sec)

      ! --- dav1(idav,16): Emittance(norm)  x-xp (mm*mrad)
      ! --- dav1(idav,21): Emittance(norm)  y-yp (mm*mrad)
      emns = 1.e12*sqmdv/(pi*fh)
      ! et2010s
      trfprt = fh*tref*180./pi
      tcgprt = fh*tcog*180./pi
      ! TEST       n2kp=int(tofprt/360.)
      ! TEST       tofprt=tofprt-float(n2kp)*360.
      ! TEST       if(tofprt.gt.180.) tofprt=tofprt-360.
      ! cavity number, z (m), transmission (%), synchronous phase (deg), time of flight (deg) (within –180 deg and 180
      ! deg),
      ! COG relativistic beta (@ output), COG output energy (MeV), REF relativistic beta (@ output), REF output energy
      ! (MeV),
      ! horizontal emittance (mm.mrad, RMS normalized), vertical emittance (mm.mrad, RMS normalized),
      ! longitudinal emittance (RMS, ns.keV)
      trnsms = 100.*float(ngood)/float(imax)
      if (ncavnm==1) write (50, *) '# cavnum.dmp'
      if (ncavnm==1) write (50, *) '# cav     Z       trans   ', &
        'PHIs     TOF(COG)    COG        Wcog          TOF(REF)   ', &
        '    REF        Wref       Ex,RMS,n     Ey,RMS,n     El,RMS'
      if (ncavnm==1) write (50, *) '#  #     (m)       (%)    ', &
        '(deg)     (deg)      beta       (MeV)          (deg)      ', &
        '   beta       (MeV)      (mm.mrad)    (mm.mrad)    (ns.keV)'
      write (50, 7023) nrres, 0.001*dav1(idav, 24), trnsms, dphete, tcgprt, bcog, encog - xmat, trfprt, bets, &
        enrs - xmat, 0.25*dav1(idav, 16), 0.25*dav1(idav, 21), 0.25*emns
7023  format (1x, i4, 1x, e12.5, 1x, f6.2, 1x, f7.2, 1x, 2(e14.7,1x,f7.5,1x,e14.7,1x), 3(e12.5,1x))
      ! et2010e
      fh = oldfh
      ! new magnetic rigidity of the reference
      gref = 1./sqrt(1.-bets*bets)
      xmor = xmat*bets*gref
      boro = 33.356*xmor*1.e-01/aqst
      write (16, *) ilost, ' particles lost in cavity ', nrres
      call emiprt(0)
      return
    end subroutine cavnum
    ! *******************************************************************
    ! SUBROUTINE phcrest(phi0,ylg,ncell,zcrest)
    ! REFERENCE:
    ! average k (cm-1)
    ! *******************************************************************
    subroutine phcrest(phi0, ylg, ncell, zcrest)
      implicit real *8(a-h, o-z)
      common /cavnum1/xnh, xpas, fmult, npt
      common /cavnum2/b0, b1, b2, b3, b4, b5
      common /cavnum3/bgt0, bgt1, bgt2, bgt3, bgt4, bgt5
      common /cavnum5/tspl0, tspl1, tspl2, tspl3, tspl4, tspl5
      common /consta/vl, pi, xmat, rpel, qst
      common /spl/xspl(4000), yspl(4000), s(5000), p(5000), q(5000)
      common /ttfc/tk, t1k, t2k, sk, s1k, s2k, fh
      common /dyn/tref, vref
      ! ylg(cm) length of cavity, xpas(cm): step length
      ! 8 steps over a cell
      npas = ncell*10
      xpas = ylg/float(npas)
      e0 = xmat
      b0 = vref/vl
      b1 = b0
      b2 = b0
      b3 = b0
      b4 = b0
      b5 = b0
      t0 = 0.
      gam0 = 1./sqrt(1.-b0*b0)
      xnh = 0.
      estop = xpas/10.
20    continue
      ! cc        if(xnh*xpas.ge.ylg) go to 10
      xpat = xnh*xpas
      if (xpat<(ylg-estop)) then
        call fposb
        ! ---  enegy gain over the step
        ! predictor of energy gain
        b1 = b0
        b2 = b0
        b3 = b0
        b4 = b0
        b5 = b0
        dgam = xi1(phi0, t0, t5)*qst/e0
        gam5 = gam0 + dgam
        ! corrector of energy gain
        xpas2 = xpas*xpas
        dgdz = qst/e0*tspl0
        d2gdz2 = dgam/xpas2 - dgdz/xpas
        d2gdz2 = 2.*d2gdz2
        gam1 = gam0 + dgdz*xpas/5. + d2gdz2*xpas2/50.
        gam2 = gam0 + dgdz*xpas*2./5. + d2gdz2*xpas2*4./50.
        gam3 = gam0 + dgdz*xpas*3./5. + d2gdz2*xpas2*9./50.
        gam4 = gam0 + dgdz*xpas*4./5. + d2gdz2*xpas2*16./50.
        b1 = sqrt(gam1*gam1-1.)/gam1
        b2 = sqrt(gam2*gam2-1.)/gam2
        b3 = sqrt(gam3*gam3-1.)/gam3
        b4 = sqrt(gam4*gam4-1.)/gam4
        b5 = sqrt(gam5*gam5-1.)/gam5
        dgam = xi1(phi0, t0, t5)*qst/e0
        gam5 = gam0 + dgam
        b5 = sqrt(gam5*gam5-1.)/gam5
        b0 = b5
        t0 = t5
        gam0 = gam5
        xnh = xnh + 1.
        go to 20
      end if
      ! compute an average k: zcrest
      zcrest = fh*t5/ylg
      return
    end subroutine phcrest
    ! *******************************************************************
    ! SUBROUTINE phcrest1(phi0,ylg,ncell)
    ! REFERENCE:
    ! computation of the phase giving the maximum energy gain)
    ! *******************************************************************
    subroutine phcrest1(phi0, ylg, ncell)
      implicit real *8(a-h, o-z)
      common /cavnum1/xnh, xpas, fmult, npt
      common /cavnum2/b0, b1, b2, b3, b4, b5
      common /cavnum3/bgt0, bgt1, bgt2, bgt3, bgt4, bgt5
      common /cavnum5/tspl0, tspl1, tspl2, tspl3, tspl4, tspl5
      common /consta/vl, pi, xmat, rpel, qst
      common /spl/xspl(4000), yspl(4000), s(5000), p(5000), q(5000)
      common /ttfc/tk, t1k, t2k, sk, s1k, s2k, fh
      common /dyn/tref, vref
      dimension stx(400), sty(400), sts(400), stp(400), stq(400)
      dimension phc(100), wph(100)
      ! ylg(cm) length of cavity, xpas(cm): step length
      npas = ncell*10
      xpas = ylg/float(npas)
      e0 = xmat
      rad = pi/180.
      dph = rad
      dph1 = rad
      dplim = rad*0.01
      pmax = phi0 + 10.*rad
      pmin = phi0 - 10.*rad
      ibcl = 1
      phi = pmin
30    continue
      if (phi>=pmax) go to 50
      phc(ibcl) = phi
      b0 = vref/vl
      b1 = b0
      b2 = b0
      b3 = b0
      b4 = b0
      b5 = b0
      t0 = 0.
      gam0 = 1./sqrt(1.-b0*b0)
      wwref = (gam0-1.)*e0
      xnh = 0.
20    continue
      if (xnh*xpas>=ylg) go to 10
      call fposb
      ! ---  enegy gain over the step
      ! predictor of energy gain
      b1 = b0
      b2 = b0
      b3 = b0
      b4 = b0
      b5 = b0
      dgam = xi1(phi, t0, t5)*qst/e0
      gam5 = gam0 + dgam
      ! corrector
      xpas2 = xpas*xpas
      dgdz = qst/e0*tspl0
      d2gdz2 = dgam/(xpas2) - dgdz/xpas
      d2gdz2 = 2.*d2gdz2
      gam1 = gam0 + dgdz*xpas/5. + d2gdz2*xpas2/50.
      gam2 = gam0 + dgdz*xpas*2./5. + d2gdz2*xpas2*4./50.
      gam3 = gam0 + dgdz*xpas*3./5. + d2gdz2*xpas2*9./50.
      gam4 = gam0 + dgdz*xpas*4./5. + d2gdz2*xpas2*16./50.
      b1 = sqrt(gam1*gam1-1.)/gam1
      b2 = sqrt(gam2*gam2-1.)/gam2
      b3 = sqrt(gam3*gam3-1.)/gam3
      b4 = sqrt(gam4*gam4-1.)/gam4
      b5 = sqrt(gam5*gam5-1.)/gam5
      dgam = xi1(phi, t0, t5)*qst/e0
      gam5 = gam0 + dgam
      b5 = sqrt(gam5*gam5-1.)/gam5
      b0 = b5
      t0 = t5
      gam0 = gam5
      xnh = xnh + 1.
      go to 20
10    continue
      wwpcr = (gam0-1.)*e0
      dwcpr = wwpcr - wwref
      wph(ibcl) = dwcpr
      phi = phi + dph
      ibcl = ibcl + 1
      go to 30
50    continue
      ibcl = ibcl - 1
      ! save spline areas (partial save)
      do i = 1, 400
        stx(i) = xspl(i)
        sty(i) = yspl(i)
        sts(i) = s(i)
        stp(i) = p(i)
        stq(i) = q(i)
      end do
      ! padding spline areas
      do i = 1, ibcl
        xspl(i) = phc(i)
        yspl(i) = wph(i)
      end do
      call deriv2(ibcl)
      i = 1
      phi = xspl(1)
      yfb = slope(ibcl, phi)/100.
70    continue
      if (phi>=xspl(ibcl)) go to 60
      if (dph1<=dplim) go to 60
      yf = slope(ibcl, phi)
      ! cccc      if(abs(yf).lt.yfb) go to 60
      if (yf>0.) then
        phi = phi + dph1
        go to 70
      else
        phi = phi - dph1
        dph1 = dph1/2.
        phi = phi + dph1
        go to 70
      end if
60    continue
      phi0 = phi
      ! restore spline areas (partial save)
      do i = 1, 400
        xspl(i) = stx(i)
        yspl(i) = sty(i)
        s(i) = sts(i)
        p(i) = stp(i)
        q(i) = stq(i)
      end do
      return
    end subroutine phcrest1
    ! *******************************************************************
    ! SUBROUTINE dwref(phi0,gam5,t5)
    ! compute the energy gain and the time of flight of the reference
    ! over the cavity(gap) at the exit of the cavity(gap):
    ! gam4 = relativistic gamma,  t4 = tof (cavity)
    ! *******************************************************************
    subroutine dwref(phi0, gam5, t5)
      implicit real *8(a-h, o-z)
      common /cavnum1/xnh, xpas, fmult, npt
      common /cavnum2/b0, b1, b2, b3, b4, b5
      common /cavnum5/tspl0, tspl1, tspl2, tspl3, tspl4, tspl5
      common /cavnum7/sspl0, sspl1, sspl2, sspl3, sspl4, sspl5
      common /consta/vl, pi, xmat, rpel, qst
      common /spl/xspl(4000), yspl(4000), s(5000), p(5000), q(5000)
      common /ttfc/tk, t1k, t2k, sk, s1k, s2k, fh
      common /dyn/tref, vref
      common /cell/yf(10000), xf(10000), xlim(15), flength, fhc, att, npoint(15), ncell
      common /step/istep
      common /compt/nrres, nrtre, nrbunc, nrdbun
      common /kcell/avrg(15)
      common /xitrd3/bcour1(15), bcour2(15), tr3dw(15), tr3ph(15), t0tr3d(15)
      common /sphi/tcour1(15), tcour2(15)
      common /t3dfld/fldctr(15), zend(15), t3d
      logical t3d
      ! save previous xpas
      xpcel = xpas

      xlpos = 0.
      isce = 20
      xlcum = 0.
      b0 = vref/vl
      b1 = b0
      b2 = b0
      b3 = b0
      b4 = b0
      b5 = b0
      t0 = 0.
      ! xlcel (cm): length of current cell
      ! xlim(inc) cm: limits of current cell
      ! isce: step number in cell (forced isce = 20)
      ! wdgam: energy gain over the cell
      ! **************************************
      do inc = 1, ncell
        bcour1(inc) = b0
        tcour1(inc) = t0
        wdgams = 0.
        xnh = 0.
        xlcel = xlim(inc+1) - xlim(inc)
        xlpos = xlpos + xlcel
        xpas = xlcel/float(isce)
        e0 = xmat
        xnhc = 0
        gam0 = 1./sqrt(1.-b0*b0)
        estop = xpas/10.
        istop = 0
20      continue
        xpat = xnhc*xpas
        if (xpat<(xlcel-estop)) then
          call fposbb(xlcum)
          ! ---  energy gain over the step
          b1 = b0
          b2 = b0
          b3 = b0
          b4 = b0
          b5 = b0
          ! predictor
          dgam = xi1(phi0, t0, t5)*qst/e0
          gam5 = gam0 + dgam
          ! corrector
          xpas2 = xpas*xpas
          dgdz = qst/e0*tspl0
          d2gdz2 = dgam/xpas2 - dgdz/xpas
          d2gdz2 = 2.*d2gdz2
          gam1 = gam0 + dgdz*xpas/5. + d2gdz2*xpas2/50.
          gam2 = gam0 + dgdz*xpas*2./5. + d2gdz2*xpas2*4./50.
          gam3 = gam0 + dgdz*xpas*3./5. + d2gdz2*xpas2*9./50.
          gam4 = gam0 + dgdz*xpas*4./5. + d2gdz2*xpas2*16./50.
          b1 = sqrt(gam1*gam1-1.)/gam1
          b2 = sqrt(gam2*gam2-1.)/gam2
          b3 = sqrt(gam3*gam3-1.)/gam3
          b4 = sqrt(gam4*gam4-1.)/gam4
          b5 = sqrt(gam5*gam5-1.)/gam5
          dgam = xi1(phi0, t0, t5)*qst/e0
          gam5 = gam0 + dgam
          eww = xmat*(gam5-1.)
          wdgam = xmat*dgam
          wdgams = wdgams + wdgam
          ! ccc        write(13,*) ' inc wdgam eww t5 ',inc,wdgam,eww,t5
          b5 = sqrt(gam5*gam5-1.)/gam5
          b0 = b5
          t0 = t5
          gam0 = gam5
          xnh = xnh + 1.
          xnhc = xnhc + 1.
          go to 20
        end if
        tcour2(inc) = t5
        xlcum = xlcum + xlcel
        ttvol = t5*fh*180./pi
        ttphi = ttvol + tref*fh*180/pi
        bcour2(inc) = b5
        tr3dw(inc) = wdgams
        ! ************************************************
        write (13, 101) nrres, inc, xlim(inc), xlim(inc+1), xlcel, eww, wdgams, ttvol, ttphi, avrg(inc)
101     format (2(2x,i4), 8(2x,e12.5))
        fldctr(inc) = avrg(inc) - xlim(inc)
        zend(inc) = xlcel - fldctr(inc)
      end do
      call itrd3
      ! restore  xpas
      xpas = xpcel
      return
    end subroutine dwref
    ! *******************************************************************
    ! SUBROUTINE itrd3
    ! *******************************************************************
    subroutine itrd3
      implicit real *8(a-h, o-z)
      common /cell/yf(10000), xf(10000), xlim(15), flength, fhc, att, npoint(15), ncell
      common /consta/vl, pi, xmat, rpel, qst
      common /xitrd3/bcour1(15), bcour2(15), tr3dw(15), tr3ph(15), t0tr3d(15)
      common /cavnum1/xnh, xpas, ffield, npt
      common /sphi/tcour1(15), tcour2(15)
      common /kcell/avrg(15)
      common /ttfc/tk, t1k, t2k, sk, s1k, s2k, fh
      dimension ttr3d(15), str3d(15)

      do nrc = 1, ncell
        bcour = (bcour1(nrc)+bcour2(nrc))/2.
        ttr3d(nrc) = ta0(bcour, nrc)
      end do
      do nrc = 1, ncell
        bcour = (bcour1(nrc)+bcour2(nrc))/2.
        str3d(nrc) = sb0(bcour, nrc)
      end do
      do nrc = 1, ncell
        t0tr3d(nrc) = qst*sqrt(ttr3d(nrc)**2+str3d(nrc)**2)*ffield/2.
        atr3d = 0.
        tt = tr3dw(nrc)/t0tr3d(nrc)
        tph = atan(-str3d(nrc)/ttr3d(nrc))
        if (tt<1.) atr3d = acos(tt)
        ddw = ttr3d(nrc)*cos(tph) - str3d(nrc)*sin(tph)
        if (ddw<0.) then
          tph = tph + pi
        end if
        ! if(tph.ge.pcrest) atr3d=-atr3d
        drift1 = avrg(nrc) - xlim(nrc)
        drift2 = xlim(nrc+1) - avrg(nrc)
        xsign1 = tcour2(nrc) - tcour1(nrc)
        xsing = xsign1 - (drift1/bcour1(nrc)+drift2/bcour2(nrc))/vl
        if (xsing>0.) atr3d = -atr3d
        tr3ph(nrc) = atr3d*180./pi
        write (13, 100) nrc, t0tr3d(nrc), ttr3d(nrc), str3d(nrc), tr3dw(nrc), atr3d*180./pi, tph*180./pi
100     format (2x, i4, 6(2x,e12.5))
      end do
      return
    end subroutine itrd3
    ! *******************************************************************
    ! SUBROUTINE fposbbb(xlcum,fposs,jx)
    ! electric field at the 6 Bode's positions in the step (see routine
    ! dwref)
    ! *******************************************************************
    subroutine fposbbb(xlcum, fposs, jx)
      implicit real *8(a-h, o-z)
      common /cavnum1/xnh, xpas, fmult, npt
      common /cavnum5/tspl0, tspl1, tspl2, tspl3, tspl4, tspl5
      common /cavnum6/fpos0, fpos1, fpos2, fpos3, fpos4, fpos5
      common /spl/xspl(4000), yspl(4000), s(5000), p(5000), q(5000)
      common /rfield/ifield
      common /xposi/xpost(10), xlce(2), xpax(2), iscx(2)
      logical ifield

      if (fposs==0.) then
        fpos0 = xnh*xpas + xlcum + fposs
        fpos1 = (xnh+0.20)*xpas + xlcum + fposs
        fpos2 = (xnh+0.40)*xpas + xlcum + fposs
        fpos3 = (xnh+0.60)*xpas + xlcum + fposs
        fpos4 = (xnh+0.80)*xpas + xlcum + fposs
        fpos5 = (xnh+1.0)*xpas + xlcum + fposs
      else
        fpos0 = xnh*xpas + fposs
        fpos1 = (xnh+0.20)*xpas + fposs
        fpos2 = (xnh+0.40)*xpas + fposs
        fpos3 = (xnh+0.60)*xpas + fposs
        fpos4 = (xnh+0.80)*xpas + fposs
        fpos5 = (xnh+1.0)*xpas + fposs
      end if
      if (jx==1) then
        xnh1 = xnh + 1
        if (xnh1==float(iscx(jx))) fposs = fpos5
      end if
      if (ifield) then
        ! --- the field is read from disk in MV/cm
        tspl0 = spline(npt, fpos0)*fmult
        tspl1 = spline(npt, fpos1)*fmult
        tspl2 = spline(npt, fpos2)*fmult
        tspl3 = spline(npt, fpos3)*fmult
        tspl4 = spline(npt, fpos4)*fmult
        tspl5 = spline(npt, fpos5)*fmult
        ! ****TEST
        ! cc         write(13,*) 'xnh fpos tspl '
        ! write(13,700) xnh,fpos0,tspl0,xpas,fposs
        ! write(13,700) xnh,fpos1,tspl1
        ! write(13,700) xnh,fpos2,tspl2
        ! write(13,700) xnh,fpos3,tspl3
        ! write(13,700) xnh,fpos4,tspl4
        ! write(13,700) xnh,fpos5,tspl5,xpas,fposs
        ! 700      format(5(2x,e12.5))
        ! ***********************************
        go to 10
      else
        ! ++++ THIS OPTION IS NOT AVAILABLE IN THE CODE +++++++++++++
        ! the field (MV/cm) is given in the form of a Fourier series
        tspl0 = fone(fpos0)*fmult
        tspl1 = fone(fpos1)*fmult
        tspl2 = fone(fpos2)*fmult
        tspl3 = fone(fpos3)*fmult
        tspl4 = fone(fpos4)*fmult
        tspl5 = fone(fpos5)*fmult
        ! ****TEST
        ! old         write(6,*) 'xnh fmult ',xnh,fmult
        ! c         write(70,700) fpos0,tspl0
        ! c         write(70,700) fpos1,tspl1
        ! c         write(70,700) fpos2,tspl2
        ! c         write(70,700) fpos3,tspl3
        ! c         write(70,700) fpos4,tspl4
        ! old         write(70,700) fpos5,tspl5
        ! ***********************************
      end if
10    continue
      return
    end subroutine fposbbb
    ! *******************************************************************
    ! SUBROUTINE fposbb(xlcum)
    ! electric field at the 6 Bode's positions in the step  (see routine
    ! dwref1)
    ! *******************************************************************
    subroutine fposbb(xlcum)
      implicit real *8(a-h, o-z)
      common /cavnum1/xnh, xpas, fmult, npt
      common /cavnum5/tspl0, tspl1, tspl2, tspl3, tspl4, tspl5
      common /cavnum6/fpos0, fpos1, fpos2, fpos3, fpos4, fpos5
      common /spl/xspl(4000), yspl(4000), s(5000), p(5000), q(5000)
      common /rfield/ifield
      logical ifield
      ! *******************************************
      fpos0 = xnh*xpas + xlcum
      fpos1 = (xnh+0.20)*xpas + xlcum
      fpos2 = (xnh+0.40)*xpas + xlcum
      fpos3 = (xnh+0.60)*xpas + xlcum
      fpos4 = (xnh+0.80)*xpas + xlcum
      fpos5 = (xnh+1.0)*xpas + xlcum
      if (ifield) then
        ! --- the field is read from disk in MV/cm
        tspl0 = spline(npt, fpos0)*fmult
        tspl1 = spline(npt, fpos1)*fmult
        tspl2 = spline(npt, fpos2)*fmult
        tspl3 = spline(npt, fpos3)*fmult
        tspl4 = spline(npt, fpos4)*fmult
        tspl5 = spline(npt, fpos5)*fmult
        ! ****TEST
        ! cc         write(13,*) 'xnh fpos tspl '
        ! c         write(13,700) xnh,fpos0,tspl0,xpas
        ! write(13,700) xnh,fpos1,tspl1
        ! write(13,700) xnh,fpos2,tspl2
        ! write(13,700) xnh,fpos3,tspl3
        ! write(13,700) xnh,fpos4,tspl4
        ! write(13,700) xnh,fpos5,tspl5,xpas
        ! 700      format(4(2x,e12.5))
        ! ***********************************
        go to 10
      else
        ! the field (MV/cm) is given in the form of a Fourier series
        tspl0 = fone(fpos0)*fmult
        tspl1 = fone(fpos1)*fmult
        tspl2 = fone(fpos2)*fmult
        tspl3 = fone(fpos3)*fmult
        tspl4 = fone(fpos4)*fmult
        tspl5 = fone(fpos5)*fmult
        ! ****TEST
        ! old         write(6,*) 'xnh fmult ',xnh,fmult
        ! c         write(70,700) fpos0,tspl0
        ! c         write(70,700) fpos1,tspl1
        ! c         write(70,700) fpos2,tspl2
        ! c         write(70,700) fpos3,tspl3
        ! c         write(70,700) fpos4,tspl4
        ! old         write(70,700) fpos5,tspl5
        ! ***********************************
      end if
10    continue
      return
    end subroutine fposbb
    ! *******************************************************************
    ! SUBROUTINE fposb
    ! electric field at the 6 Bode's positions in the step
    ! *******************************************************************
    subroutine fposb
      implicit real *8(a-h, o-z)
      common /cavnum1/xnh, xpas, fmult, npt
      common /cavnum5/tspl0, tspl1, tspl2, tspl3, tspl4, tspl5
      common /cavnum6/fpos0, fpos1, fpos2, fpos3, fpos4, fpos5
      common /spl/xspl(4000), yspl(4000), s(5000), p(5000), q(5000)
      common /rfield/ifield
      logical ifield

      fpos0 = xnh*xpas
      fpos1 = (xnh+0.20)*xpas
      fpos2 = (xnh+0.40)*xpas
      fpos3 = (xnh+0.60)*xpas
      fpos4 = (xnh+0.80)*xpas
      fpos5 = (xnh+1.0)*xpas
      if (ifield) then
        ! --- the field is read from disk in MV/cm
        tspl0 = spline(npt, fpos0)*fmult
        tspl1 = spline(npt, fpos1)*fmult
        tspl2 = spline(npt, fpos2)*fmult
        tspl3 = spline(npt, fpos3)*fmult
        tspl4 = spline(npt, fpos4)*fmult
        tspl5 = spline(npt, fpos5)*fmult
        ! ****TEST
        ! old         write(6,*) 'xnh fmult ',xnh,fmult
        ! c         write(13,700) xnh,fpos0,tspl0
        ! c         write(13,700) xnh,fpos1,tspl1
        ! c         write(13,700) xnh,fpos2,tspl2
        ! c         write(13,700) xnh,fpos3,tspl3
        ! c         write(13,700) xnh,fpos4,tspl4
        ! c         write(13,700) xnh,fpos5,tspl5
        ! c700      format(3(2x,e12.5))
        ! ***********************************
        go to 10
      else
        ! the field (MV/cm) is given in the form of a Fourier series
        tspl0 = fone(fpos0)*fmult
        tspl1 = fone(fpos1)*fmult
        tspl2 = fone(fpos2)*fmult
        tspl3 = fone(fpos3)*fmult
        tspl4 = fone(fpos4)*fmult
        tspl5 = fone(fpos5)*fmult
        ! ****TEST
        ! old         write(6,*) 'xnh fmult ',xnh,fmult
        ! c         write(70,700) fpos0,tspl0
        ! c         write(70,700) fpos1,tspl1
        ! c         write(70,700) fpos2,tspl2
        ! c         write(70,700) fpos3,tspl3
        ! c         write(70,700) fpos4,tspl4
        ! old         write(70,700) fpos5,tspl5
        ! ***********************************
      end if
10    continue
      return
    end subroutine fposb
    ! *******************************************************************
    ! SUBROUTINE sposb
    ! derivative of electric field at the 6 Bode's positions in the step
    ! not used in the code
    ! *******************************************************************
    subroutine sposb
      implicit real *8(a-h, o-z)
      common /cavnum1/xnh, xpas, fmult, npt
      common /cavnum5/tspl0, tspl1, tspl2, tspl3, tspl4, tspl5
      common /cavnum6/fpos0, fpos1, fpos2, fpos3, fpos4, fpos5
      common /cavnum7/sspl0, sspl1, sspl2, sspl3, sspl4, sspl5
      common /spl/xspl(4000), yspl(4000), s(5000), p(5000), q(5000)
      common /rfield/ifield
      logical ifield

      fpos0 = xnh*xpas
      fpos1 = (xnh+0.20)*xpas
      fpos2 = (xnh+0.40)*xpas
      fpos3 = (xnh+0.60)*xpas
      fpos4 = (xnh+0.80)*xpas
      fpos5 = (xnh+1.0)*xpas
      if (ifield) then
        ! --- the field is read from disk in MV/cm
        sspl0 = slope(npt, fpos0)*fmult
        sspl1 = slope(npt, fpos1)*fmult
        sspl2 = slope(npt, fpos2)*fmult
        sspl3 = slope(npt, fpos3)*fmult
        sspl4 = slope(npt, fpos4)*fmult
        sspl5 = slope(npt, fpos5)*fmult
        ! ****TEST
        ! old         write(6,*) 'xnh fmult ',xnh,fmult
        ! cc         write(13,700) xnh,fpos0,sspl0
        ! cc         write(13,700) xnh,fpos1,sspl1
        ! cc         write(13,700) xnh,fpos2,sspl2
        ! cc         write(13,700) xnh,fpos3,sspl3
        ! cc         write(13,700) xnh,fpos4,sspl4
        ! cc         write(13,700) xnh,fpos5,sspl5
        ! cc700      format(3(2x,e12.5))
        ! ***********************************
        go to 10
      else
        ! the field (MV/cm) is given in the form of a Fourier series
        tspl0 = fone(fpos0)*fmult
        tspl1 = fone(fpos1)*fmult
        tspl2 = fone(fpos2)*fmult
        tspl3 = fone(fpos3)*fmult
        tspl4 = fone(fpos4)*fmult
        tspl5 = fone(fpos5)*fmult
        ! ****TEST
        ! old         write(6,*) 'xnh fmult ',xnh,fmult
        ! c         write(70,700) fpos0,tspl0
        ! c         write(70,700) fpos1,tspl1
        ! c         write(70,700) fpos2,tspl2
        ! c         write(70,700) fpos3,tspl3
        ! c         write(70,700) fpos4,tspl4
        ! old         write(70,700) fpos5,tspl5
        ! ***********************************
      end if
10    continue
      return
    end subroutine sposb
    ! *******************************************************************
    ! FUNCTION xi1(phi0,t0,t5)
    ! energy gain over the step
    ! *******************************************************************
    function xi1(phi0, t0, t5)
      implicit real *8(a-h, o-z)
      common /cavnum1/xnh, xpas, fmult, npt
      common /cavnum2/b0, b1, b2, b3, b4, b5
      common /cavnum5/tspl0, tspl1, tspl2, tspl3, tspl4, tspl5
      common /consta/vl, pi, xmat, rpel, qst
      common /ttfc/tk, t1k, t2k, sk, s1k, s2k, fh

      xi1 = 0.
      b01 = (b0+b1)/2.
      b12 = (b1+b2)/2.
      b23 = (b2+b3)/2
      b34 = (b3+b4)/2
      b45 = (b4+b5)/2
      t1 = t0 + xpas/(5.*b01*vl)
      t2 = t1 + xpas/(5.*b12*vl)
      t3 = t2 + xpas/(5.*b23*vl)
      t4 = t3 + xpas/(5.*b34*vl)
      t5 = t4 + xpas/(5.*b45*vl)
      xspl0 = cos(fh*t0+phi0)*tspl0
      xspl1 = cos(fh*t1+phi0)*tspl1
      xspl2 = cos(fh*t2+phi0)*tspl2
      xspl3 = cos(fh*t3+phi0)*tspl3
      xspl4 = cos(fh*t4+phi0)*tspl4
      xspl5 = cos(fh*t5+phi0)*tspl5
      tspl = 19.*xspl0 + 75.*xspl1 + 50.*xspl2 + 50.*xspl3 + 75.*xspl4 + 19.*xspl5
      xi1 = xpas/288.*tspl
      return
    end function xi1
    ! *******************************************************************
    ! FUNCTION xi2(phi0,t0)
    ! coupling terms in R and R' (energy gain)
    ! *******************************************************************
    function xi2(phi0, t0)
      implicit real *8(a-h, o-z)
      common /cavnum1/xnh, xpas, fmult, npt
      common /cavnum2/b0, b1, b2, b3, b4, b5
      common /cavnum5/tspl0, tspl1, tspl2, tspl3, tspl4, tspl5
      common /consta/vl, pi, xmat, rpel, qst
      common /ttfc/tk, t1k, t2k, sk, s1k, s2k, fh

      b01 = (b0+b1)/2.
      b12 = (b1+b2)/2.
      b23 = (b2+b3)/2.
      b34 = (b3+b4)/2.
      b45 = (b4+b5)/2.
      t1 = t0 + xpas/(5.*b01*vl)
      t2 = t1 + xpas/(5.*b12*vl)
      t3 = t2 + xpas/(5.*b23*vl)
      t4 = t3 + xpas/(5.*b34*vl)
      t5 = t4 + xpas/(5.*b45*vl)
      ! old       xspl0=cos(fh*t0+phi0)*tspl0
      xspl1 = cos(fh*t1+phi0)*tspl1
      xspl2 = cos(fh*t2+phi0)*tspl2
      xspl3 = cos(fh*t3+phi0)*tspl3
      xspl4 = cos(fh*t4+phi0)*tspl4
      xspl5 = cos(fh*t5+phi0)*tspl5
      tspl = 15.*xspl1 + 20.*xspl2 + 30.*xspl3 + 60*xspl4 + 19.*xspl5
      xi2 = xpas*xpas/288.*tspl
      return
    end function xi2
    ! *******************************************************************
    ! FUNCTION xj1(phi0,t0)
    ! transverse motion field dE/dt
    ! *******************************************************************
    function xj1(phi0, t0)
      implicit real *8(a-h, o-z)
      common /cavnum1/xnh, xpas, fmult, npt
      common /cavnum2/b0, b1, b2, b3, b4, b5
      common /cavnum3/bgt0, bgt1, bgt2, bgt3, bgt4, bgt5
      common /cavnum5/tspl0, tspl1, tspl2, tspl3, tspl4, tspl5
      common /consta/vl, pi, xmat, rpel, qst
      common /ttfc/tk, t1k, t2k, sk, s1k, s2k, fh
      ! --- the field is read on the disk
      xj1 = 0.
      b01 = (b0+b1)/2.
      b12 = (b1+b2)/2.
      b23 = (b2+b3)/2.
      b34 = (b3+b4)/2.
      b45 = (b4+b5)/2.
      t1 = t0 + xpas/(5.*b01*vl)
      t2 = t1 + xpas/(5.*b12*vl)
      t3 = t2 + xpas/(5.*b23*vl)
      t4 = t3 + xpas/(5.*b34*vl)
      t5 = t4 + xpas/(5.*b45*vl)
      xspl0 = -fh*sin(fh*t0+phi0)*tspl0/bgt0
      xspl1 = -fh*sin(fh*t1+phi0)*tspl1/bgt1
      xspl2 = -fh*sin(fh*t2+phi0)*tspl2/bgt2
      xspl3 = -fh*sin(fh*t3+phi0)*tspl3/bgt3
      xspl4 = -fh*sin(fh*t4+phi0)*tspl4/bgt4
      xspl5 = -fh*sin(fh*t5+phi0)*tspl5/bgt5
      tspl = 19.*xspl0 + 75.*xspl1 + 50.*xspl2 + 50.*xspl3 + 75.*xspl4 + 19.*xspl5
      xj1 = xpas/288.*tspl
      return
    end function xj1
    ! *******************************************************************
    ! FUNCTION xj2(phi0,t0)
    ! transverse motion field dE/dt
    ! *******************************************************************
    function xj2(phi0, t0)
      implicit real *8(a-h, o-z)
      common /cavnum1/xnh, xpas, fmult, npt
      common /cavnum2/b0, b1, b2, b3, b4, b5
      common /cavnum3/bgt0, bgt1, bgt2, bgt3, bgt4, bgt5
      common /cavnum5/tspl0, tspl1, tspl2, tspl3, tspl4, tspl5
      common /consta/vl, pi, xmat, rpel, qst
      common /ttfc/tk, t1k, t2k, sk, s1k, s2k, fh

      xj2 = 0.
      b01 = (b0+b1)/2.
      b12 = (b1+b2)/2.
      b23 = (b2+b3)/2.
      b34 = (b3+b4)/2.
      b45 = (b4+b5)/2.
      t1 = t0 + xpas/(5.*b01*vl)
      t2 = t1 + xpas/(5.*b12*vl)
      t3 = t2 + xpas/(5.*b23*vl)
      t4 = t3 + xpas/(5.*b34*vl)
      t5 = t4 + xpas/(5.*b45*vl)
      xspl1 = -fh*sin(fh*t1+phi0)*tspl1/bgt1
      xspl2 = -fh*sin(fh*t2+phi0)*tspl2/bgt2
      xspl3 = -fh*sin(fh*t3+phi0)*tspl3/bgt3
      xspl4 = -fh*sin(fh*t4+phi0)*tspl4/bgt4
      xspl5 = -fh*sin(fh*t5+phi0)*tspl5/bgt5
      tspl = 15.*xspl1 + 20.*xspl2 + 30.*xspl3 + 60.*xspl4 + 19.*xspl5
      xj2 = xpas*xpas/288.*tspl
      return
    end function xj2
    ! *******************************************************************
    ! FUNCTION xe21(phi0,t0)
    ! transverse motion field E*E
    ! *******************************************************************
    function xe21(phi0, t0)
      implicit real *8(a-h, o-z)
      common /cavnum1/xnh, xpas, fmult, npt
      common /cavnum2/b0, b1, b2, b3, b4, b5
      common /cavnum4/bge0, bge1, bge2, bge3, bge4, bge5
      common /cavnum5/tspl0, tspl1, tspl2, tspl3, tspl4, tspl5
      common /consta/vl, pi, xmat, rpel, qst
      common /ttfc/tk, t1k, t2k, sk, s1k, s2k, fh

      xe21 = 0.
      b01 = (b0+b1)/2.
      b12 = (b1+b2)/2.
      b23 = (b2+b3)/2.
      b34 = (b3+b4)/2.
      b45 = (b4+b5)/2.
      t1 = t0 + xpas/(5.*b01*vl)
      t2 = t1 + xpas/(5.*b12*vl)
      t3 = t2 + xpas/(5.*b23*vl)
      t4 = t3 + xpas/(5.*b34*vl)
      t5 = t4 + xpas/(5.*b45*vl)
      xspl0 = cos(fh*t0+phi0)*tspl0
      xspl1 = cos(fh*t1+phi0)*tspl1
      xspl2 = cos(fh*t2+phi0)*tspl2
      xspl3 = cos(fh*t3+phi0)*tspl3
      xspl4 = cos(fh*t4+phi0)*tspl4
      xspl5 = cos(fh*t5+phi0)*tspl5
      xspl0 = xspl0*xspl0*bge0
      xspl1 = xspl1*xspl1*bge1
      xspl2 = xspl2*xspl2*bge2
      xspl3 = xspl3*xspl3*bge3
      xspl4 = xspl4*xspl4*bge4
      xspl5 = xspl5*xspl5*bge5
      tspl = 19.*xspl0 + 75.*xspl1 + 50.*xspl2 + 50.*xspl3 + 75.*xspl4 + 19.*xspl5
      xe21 = xpas/288.*tspl
      return
    end function xe21
    ! *******************************************************************
    ! FUNCTION xe22(phi0,t0)
    ! transverse motion for field E*E
    ! *******************************************************************
    function xe22(phi0, t0)
      implicit real *8(a-h, o-z)
      common /cavnum1/xnh, xpas, fmult, npt
      common /cavnum2/b0, b1, b2, b3, b4, b5
      common /cavnum4/bge0, bge1, bge2, bge3, bge4, bge5
      common /cavnum5/tspl0, tspl1, tspl2, tspl3, tspl4, tspl5
      common /consta/vl, pi, xmat, rpel, qst
      common /spl/xspl(4000), yspl(4000), s(5000), p(5000), q(5000)
      common /dyn/tref, vref
      common /ttfc/tk, t1k, t2k, sk, s1k, s2k, fh
      common /rfield/ifield
      logical ifield

      xe22 = 0.
      b01 = (b0+b1)/2.
      b12 = (b1+b2)/2.
      b23 = (b2+b3)/2.
      b34 = (b3+b4)/2.
      b45 = (b4+b5)/2.
      t1 = t0 + xpas/(5.*b01*vl)
      t2 = t1 + xpas/(5.*b12*vl)
      t3 = t2 + xpas/(5.*b23*vl)
      t4 = t3 + xpas/(5.*b34*vl)
      t5 = t4 + xpas/(5.*b45*vl)
      xspl1 = cos(fh*t1+phi0)*tspl1
      xspl2 = cos(fh*t2+phi0)*tspl2
      xspl3 = cos(fh*t3+phi0)*tspl3
      xspl4 = cos(fh*t4+phi0)*tspl4
      xspl5 = cos(fh*t4+phi0)*tspl5
      xspl1 = xspl1*xspl1*bge1
      xspl2 = xspl2*xspl2*bge2
      xspl3 = xspl3*xspl3*bge3
      xspl4 = xspl4*xspl4*bge4
      xspl5 = xspl5*xspl5*bge5
      tspl = 15.*xspl1 + 20.*xspl2 + 30.*xspl3 + 60.*xspl4 + 19.*xspl5
      xe22 = xpas*xpas/288.*tspl
      return
    end function xe22
    ! *******************************************************************
    ! SUBROUTINE bcnum(phref,ylg,ncell)
    ! dynamics of the bunch
    ! *******************************************************************
    subroutine bcnum(phref, ylg, ncell)
      implicit real *8(a-h, o-z)
      parameter(iptsz=100002, maxcell=3000, maxcell1=3000)
      common /dyn/tref, vref
      common /sc3/beamc, scdist, sce10, cplm, ect, apl, ichaes, iscsp
      common /dcspa/iesp
      common /ttfc/tk, t1k, t2k, sk, s1k, s2k, fh
      common /faisc/f(10, iptsz), imax, ngood
      common /consta/vl, pi, xmat, rpel, qst
      common /cavnum1/xnh, xpas, fmult, npt
      common /cavnum2/b0, b1, b2, b3, b4, b5
      common /cavnum3/bgt0, bgt1, bgt2, bgt3, bgt4, bgt5
      common /cavnum4/bge0, bge1, bge2, bge3, bge4, bge5
      common /cavnum5/tspl0, tspl1, tspl2, tspl3, tspl4, tspl5
      common /rfield/ifield
      common /testref/trefs, ddw
      common /elec/jelec
      common /step/istep
      dimension gam(500), xe(500), xpe(500), ye(500), ype(500)
      dimension tcour(iptsz), phi(iptsz)
      logical ifield, flgsc, ichaes, iesp, jelec
      ! ylg(cm) length of cavity, xpas(cm): step length
      ! 8 steps over a cell (a voir!!!)
      beref = vref/vl
      gamref = 1./sqrt(1.-(beref*beref))
      enref = xmat*gamref
      e0 = xmat
      npas = ncell*istep
      xpas = ylg/float(npas)
      npas1 = npas + 1
      xnh = 0.
      ! flgsc = true ---> s.c. computation
      ! eglsc = 2*xpas : acting length of s.c. computation
      eglsc = 2.*xpas
      flgsc = .false.
      do i = 2, npas1
        i1 = i - 1
        ! --- seek the field E(z) values in the 6 positions in the step length xh
        call fposb
        do j = 1, ngood
          qc = f(9, j)
          gam0 = f(7, j)/e0
          gam(i1) = gam0
          if (i1==1) then
            tcour(j) = 0.
            tof = f(6, j)
            ! --- rphas: phase delay between the actual particle  and the reference (entrance of the cavity)
            rphas = fh*(tof-tref)
            phi(j) = phref + rphas
          end if
          t0 = tcour(j)
          ddt = t0
          ! predictor (energy gain)
          b0 = sqrt(gam0*gam0-1.)/gam0
          b1 = b0
          b2 = b0
          b3 = b0
          b4 = b0
          b5 = b0
          dgam = xi1(phi(j), t0, t5)*qc/e0
          gam5 = gam(i1) + dgam
          ! corrector (energy gain)
          ! tspl0 = dE/dz  (MV/(cm*cm)
          xpas2 = xpas*xpas
          dgdz = qst/e0*tspl0
          d2gdz2 = dgam/xpas2 - dgdz/xpas
          d2gdz2 = 2.*d2gdz2
          gam1 = gam0 + dgdz*xpas/5. + d2gdz2*xpas2/50.
          gam2 = gam0 + dgdz*xpas*2./5. + d2gdz2*xpas2*4./50.
          gam3 = gam0 + dgdz*xpas*3./5. + d2gdz2*xpas2*9./50.
          gam4 = gam0 + dgdz*xpas*4./5. + d2gdz2*xpas2*16./50.
          b1 = sqrt(gam1*gam1-1.)/gam1
          b2 = sqrt(gam2*gam2-1.)/gam2
          b3 = sqrt(gam3*gam3-1.)/gam3
          b4 = sqrt(gam4*gam4-1.)/gam4
          b5 = sqrt(gam5*gam5-1.)/gam5
          dgam = xi1(phi(j), t0, t5)*qc/e0
          gam5 = gam(i1) + dgam
          b5 = sqrt(gam5*gam5-1.)/gam5
          ! tranverse coordinates in (cm,rad)
          x0 = f(2, j)
          y0 = f(4, j)
          xt0 = f(3, j)*1.e-03
          yp0 = f(5, j)*1.e-03
          ! Picht transformation: xe0 and ye0 (cm) xpe0 and ype0 (rad)
          gamm0 = (gam0*gam0-1.)**0.25
          xe0 = x0*gamm0
          xpe0 = xt0*gamm0
          ye0 = y0*gamm0
          ype0 = yp0*gamm0
          xpe0 = xpe0 + .5*xe0*gam0*dgdz/(gam0*gam0-1.)
          ype0 = ype0 + .5*ye0*gam0*dgdz/(gam0*gam0-1.)
          xe(i1) = xe0
          xpe(i1) = xpe0
          ye(i1) = ye0
          ype(i1) = ype0
          ! transverse coupling terms
          gam00 = gam0*gam0
          gam11 = gam1*gam1
          gam22 = gam2*gam2
          gam33 = gam3*gam3
          gam44 = gam4*gam4
          bgt0 = (gam00-1.)**1.5
          xk1 = fh*fh/(4.*vl*vl*bgt0)
          red = sqrt(xe(i1)*xe(i1)+ye(i1)*ye(i1))
          red2 = red*red
          dred = 0.
          if (red>1.e-08) then
            dred = xe(i1)*xpe(i1) + ye(i1)*ype(i1)
            dred = dred/red
          end if
          rk1 = xk1*red2*xi1(phi(j), t0, t5)*qc/e0
          rk2 = red*dred*xk1*xi2(phi(j), t0)*qc/e0
          gam(i) = gam5 + rk1 + rk2
          gam55 = gam(i)*gam(i)
          bgt1 = (gam11-1.)**1.5
          bgt2 = (gam22-1.)**1.5
          bgt3 = (gam33-1.)**1.5
          bgt4 = (gam44-1.)**1.5
          bgt5 = (gam55-1.)**1.5
          bge0 = (gam00+2.)/((gam00-1.)*(gam00-1.))
          bge1 = (gam11+2.)/((gam11-1.)*(gam11-1.))
          bge2 = (gam22+2.)/((gam22-1.)*(gam22-1.))
          bge3 = (gam33+2.)/((gam33-1.)*(gam33-1.))
          bge4 = (gam44+2.)/((gam44-1.)*(gam44-1.))
          bge5 = (gam55+2.)/((gam55-1.)*(gam55-1.))
          ! ******************************************************
          ! compute the jump of phase over the step
          ! old         dlt=(1.+red2*xk1)*xi3(phi(j),t0)
          ! old         dlt=dlt+red*dred*xk1*xi4(phi(j),t0)
          ! old         dlt=dlt*qc/(e0*vl)
          ! old         tof=tof+xpas/(vl*b0)+dlt
          ! *******************************************************
          f(7, j) = gam(i)*e0
          tcour(j) = t5
          ddt1 = t5 - ddt
          f(6, j) = ddt1 + f(6, j)
          ! -- angular deviation
          ! 1) terms in dE/dt
          a1 = qc/(2.*e0*vl)
          ttt1 = xj1(phi(j), t0)
          ttt2 = xj2(phi(j), t0)
          ! old         dxpe=xe(i1)*xj1(phi(j),t0)+xpe(i1)*xj2(phi(j),t0)
          ! old         dype=ye(i1)*xj1(phi(j),t0)+ype(i1)*xj2(phi(j),t0)
          dxpe1 = xe(i1)*ttt1 + xpe(i1)*ttt2
          dype1 = ye(i1)*ttt1 + ype(i1)*ttt2
          xpe(i) = xpe(i1) + a1*dxpe1
          ype(i) = ype(i1) + a1*dype1
          ! --- 2) terms in E*E (only for no-relativistic electrons)
          if (jelec) then
            ae2 = qc/(2.*e0)
            ae2 = ae2*ae2
            stt1 = xe21(phi(j), t0)
            stt2 = xe22(phi(j), t0)
            dxpe2 = xe(i1)*stt1 + xpe(i1)*stt2
            dype2 = ye(i1)*stt1 + ype(i1)*stt2
            xpe(i) = xpe(i1) + a1*dxpe1 - ae2*dxpe2
            ype(i) = ype(i1) + a1*dype1 - ae2*dype2
          end if
          ! extension
          ! old         dxe=xe(i1)*xj2(phi,t0)+xpe(i1)*xj3(phi,t0)
          ! old         dye=ye(i1)*xj2(phi,t0)+ype(i1)*xj3(phi,t0)
          ! old         xe(i)=xe(i1)+a1*dxe+xpas*xpe(i1)
          ! old         ye(i)=ye(i1)+a1*dye+xpas*ype(i1)
          xe(i) = xe(i1) + xpas*(xpe(i1)+xpe(i))/2.
          ye(i) = ye(i1) + xpas*(ype(i1)+ype(i))/2.
          ! back to the real variables and convert to (cm,mrad)
          dgdzr = qc/e0*tspl5
          gamm1 = (gam(i)*gam(i)-1.)**0.25
          gamm2 = (gam(i)*gam(i)-1.)**1.25
          xi = xe(i)/gamm1
          xpi = xpe(i)/gamm1 - xe(i)*gam(i)*dgdzr/(gamm2*2.)
          yi = ye(i)/gamm1
          ypi = ype(i)/gamm1 - ye(i)*gam(i)*dgdzr/(gamm2*2.)
          ! convert in cm and mrd
          f(2, j) = xi
          f(4, j) = yi
          f(3, j) = xpi*1.e03
          f(5, j) = ypi*1.e03
        end do
        ! space charge computation (only odd step numbers)
        if (.not. flgsc) then
          flgsc = .true.
          call disp
          ! et        endif
        else
          ! et        if(flgsc) then
          if (ichaes) then
            ! Charge space (only SCHEFF is available)
            iesp = .true.
            call cesp(eglsc)
            iesp = .false.
            flgsc = .false.
            ! Change the dispersion dE/E with respect to the C.O.G of the bunch
          end if
          call disp
        end if
        xnh = xnh + 1.
      end do
      return
    end subroutine bcnum
    ! *******************************************************************
    ! SUBROUTINE reject(ilost)
    ! reject particles outside window set by REJECT card
    ! ---- ifw = 0  ===> wdisp = dW/W relative to cog
    ! ---- ifw = 1  ===> wdisp = dW (MeV) relative to cog
    ! ---- ifw = 10 ===> wdisp = dW/W relative to REF
    ! ---- ifw = 11 ===> wdisp = dW (MeV) relative to REF
    ! *******************************************************************
    subroutine reject(ilost)
      implicit real *8(a-h, o-z)
      parameter(iptsz=100002, maxcell=3000, maxcell1=3000)
      common /consta/vl, pi, xmat, rpel, qst
      common /ttfc/tk, t1k, t2k, sk, s1k, s2k, fh
      common /faisc/f(10, iptsz), imax, ngood
      common /cgtof/charm(20), cgtdv(20), nbch(20), netac
      common /mcs/imcs, ncstat, cstat(20)
      common /etcom/cog(8), exten(17), fd(iptsz)
      common /fene/wdisp, wphas, wx, wy, rlim, ifw
      common /dyn/tref, vref

      ilost = 0
      fh0 = fh/vl
      fcpi = fh*180./pi
      ! Test window
      write (16, *) 'Check if the ', ngood, ' particles are within window'
      write (16, *) 'Number of charge states: ', ncstat
      if (ifw<=1) then
        ! Relative to COG
        write (16, 3900)
        ! ---- ifw = 0 ===> wdisp = dW/W
        ! ---- ifw = 1 ===> wdisp = dW (MeV)
        if (ncstat>1) call cogetc
        bcour = 0.
        cgtv = 0.
        do i = 1, ngood
          gpai = f(7, i)/xmat
          bcour = sqrt(1.-1./(gpai*gpai)) + bcour
          cgtv = cgtv + f(6, i)
        end do
        cgtv = cgtv/float(ngood)
        bcour = bcour/float(ngood)
        bcg = bcour
        gcour = 1./sqrt(1.-bcour*bcour)
        gcg = gcour
        wcg = (gcour-1.)*xmat
        do i = 1, ngood
          gpai = f(7, i)/xmat
          if (gpai<1.) gpai = 1.
          bcour = sqrt(1.-1./(gpai*gpai))
          fd(i) = bcour/bcg*gpai/gcg
        end do
        if (ifw==0) then
          dispr = gcour*gcour*wdisp/(gcour*(gcour+1.))
        else
          dispr = gcour*gcour*wdisp/(gcour*(gcour+1.)*wcg)
        end if
      else
        ! Relative to REF
        write (16, 3901)
        bref = vref/vl
        gref = 1./sqrt(1.-bref*bref)
        wref = (gref-1.)*xmat
        do i = 1, ngood
          gpai = f(7, i)/xmat
          bcour = sqrt(1.-1./(gpai*gpai))
          fd(i) = bcour/bref*gpai/gref
        end do
        if (ifw==10) then
          dispr = gref*gref*wdisp/(gref*(gref+1.))
        else
          dispr = gref*gref*wdisp/(gref*(gref+1.)*wref)
        end if
      end if
      write (16, 3927) rlim, wx, wy, wphas, wdisp
      ! *         ,dispr,f6i*fh*180./pi,f(7,i)-xmat,int(f(9,i))
      f6i = 0.
      do i = 1, ngood
        ray = f(2, i)*f(2, i) + f(4, i)*f(4, i)
        ray = sqrt(ray)
        if (ray>rlim) f(8, i) = 0.
        if (abs(f(2,i))>wx) f(8, i) = 0.
        if (abs(f(4,i))>wy) f(8, i) = 0.
        if (ifw<=1) then
          ! Relative to cog
          if (ncstat>1) then
            ! ---- each charge state has its own COG in phase
            do istc = 1, ncstat
              if (f(9,i)==charm(istc)) then
                f6i = f(6, i) - cgtdv(istc)
                ! tmp=cgtdv(istc)
              end if
            end do
          else
            f6i = f(6, i) - cgtv
          end if
        else
          ! Relative to REF
          f6i = f(6, i) - tref
        end if
        if (fh*abs(f6i)>=wphas) then
          f(8, i) = 0.
          ! write(16,*) "Test1:",fh*abs(f6i),wphas,tmp,f(6,i)
        end if
        if (abs(fd(i)-1.)>=dispr) then
          f(8, i) = 0.
          ! write(16,*) "Test2:",abs(fd(i)-1.)
        end if
        if (f(8,i)==0.) then
          write (16, 3928) i, int(f(1,i)), f(2, i), f(3, i), f(4, i), f(5, i), f6i*fh*180./pi, f(7, i) - xmat, f(9, i)
          ilost = ilost + 1
        end if
      end do
      ! Reshuffles f(i,j) array after window
      call shuffle
      ! cccc       cstat=1
      ncstat = 1
      cstat(1) = f(9, 1)
      do j = 2, ngood
        mcstat = 0
        do k = 1, ncstat
          if (f(9,j)==cstat(k)) then
            mcstat = 1
          end if
        end do
        if (mcstat==0) then
          ncstat = ncstat + 1
          cstat(ncstat) = f(9, j)
        end if
      end do
      netac = ncstat
      write (16, *) 'Number of good particles left: ', ngood
      write (16, *) 'Number of charge states left : ', ncstat
      write (16, 4030)(cstat(j), j=1, ncstat)
      imcs = 0
      if (ncstat>1) imcs = 1
3900  format (' Window w.r.t. COG')
3901  format (' Window w.r.t. reference particle')
3927  format (' LIM R,X,Y ', 3(f10.2,9x), 'P,W ', e12.5, 9x, e12.5)
3928  format (' # ', i5, 1x, i5, 1x, 6(f10.2,1x), 1x, f5.2)
4030  format ('Charge state(s): ', 20(f5.1,1x))
      return
    end subroutine reject
    ! *******************************************************************
    ! SUBROUTINE aimalv (ANGL,RMO,BAIM,XN,XB,EK1,EK2,PENT1,RAB1,
    ! SK1,SK2,PENT2,RAB2)
    ! FIRST AND SECOND order Bending Magnet
    ! WEDGE BENDING MAGNET
    ! ANGL : DEG  bend angle of the central trajectory
    ! RMO  : CM   radius of curvature of the central trajectory
    ! BAIM : KG   field of the bending magnet
    ! BAIM = 0  the field is computed from the momentum of the
    ! reference; otherwise the momentum is computed from
    ! the field
    ! XN   :      FIELD GRADIENT (dimensionless,TRANSPORT: n)
    ! XB   :      NORMALIZED SECOND DERIVATIVE OF B (TRANSPORT : beta)
    ! AP(1) = AP(2) CM vertical half aperture (only if IPOLE = 0)
    ! ENTRANCE FACE
    ! PENT1 EK1 EK2 RAB1
    ! PENT1: DEG   angle of pole face rotation  (deg)
    ! RAB1 : CM    radius of curvature
    ! EK1  :       integral related to the extent of the fringing field
    ! (TRANSPORT K1)
    ! EK2  :       integral related to the extent of the fringing field
    ! (TRANSPORT K2)
    ! AP(1) : CM   vertical half aperture
    ! EXIT FACE
    ! PENT2 SK1 SK2  RAB2
    ! PENT2: DEG   angle of pole face rotation
    ! RAB2 : CM  radius of curvature
    ! SK1  :     integral related to the extent of the fringing field
    ! SK2  :     integral related to the extent of the fringing field
    ! AP(2) : CM   vertical half aperture
    ! *******************************************************************
    subroutine aimalv(angl, rmo, baim, xn, xb, ek1, ek2, pent1, rab1, sk1, sk2, pent2, rab2)
      implicit real *8(a-h, o-z)
      parameter(iptsz=100002, maxcell=3000, maxcell1=3000)
      common /ttfc/tk, t1k, t2k, sk, s1k, s2k, fh
      common /sc3/beamc, scdist, sce10, cplm, ect, apl, ichaes, iscsp
      common /fene/wdisp, wphas, wx, wy, rlim, ifw
      common /davcom/dav1(maxcell1, 40), davtot, iitem(maxcell1), idav
      common /tapes/in, ifile, meta
      common /dyn/tref, vref
      common /rigid/boro
      common /faisc/f(10, iptsz), imax, ngood
      common /femt/iemgrw, iemqesg
      logical iemgrw
      common /etcom/cog(8), exten(17), fd(iptsz)
      common /qmoyen/qmoy
      common /consta/vl, pi, xmat, rpel, qst
      common /bloc23/h, devi, nb, bdb, l
      real *8 l, nb
      common /poro/irot1, irot2
      logical irot1, irot2
      common /bloc11/r(6, 6), t(6, 6, 6)
      common /bloc21/be, apb(2), layl, layx, rabt
      real *8 layl, layx
      common /pltprf/sprfx(3000), sprfy(3000), sprfl(3000), sprfw(3000), sprfp(3000), sprng(3000), iprf
      common /rander/ialin
      common /cgtof/charm(20), cgtdv(20), nbch(20), netac
      common /compt/nrres, nrtre, nrbunc, nrdbun
      common /radia/trt, rsync, xintf, crae
      common /rayshy/iraysh
      logical iraysh
      common /itvole/itvol, imamin
      common /tofev/ttvols
      common /mcs/imcs, ncstat, cstat(20)
      ! nsprint: control
      common /isector/nsector, nsprint
      ! --------------------------------------
      logical itvol, imamin, ichaes
      character *1 cr
      logical ialin
      dimension xmoy(20), ymoy(20), rmoy(20), rig(20), ncs(20)
      dimension xpmoy(20), ypmoy(20)
      dimension xcl1(20), xcl2(20), alp(20), sxeb1(20), charge(20)
      dimension xsa1b1(20), baims(20)
      ! *et*2013*Apr*1
      dimension sbeta(20)

      write (16, 100)
100   format (' ****** BENDING MAGNET: input list ****** ')
      if (baim==0.0) then
        ! BORO: momentum of reference (kG.cm)
        ri = boro
        ! --- BAIM: bend field (KG)
        baim = abs(ri/rmo)
        write (16, '(A,F4.1,A,F12.5,A)') ' Based on reference charge ', qst, ' momentum ', boro, ' (kG.cm)'
      else
        ! --- RI momentum kG.cm
        ri = baim*rmo
      end if
      devi = angl
      nb = xn
      bdb = xb
      rsync = rmo
      gap = wy
      ! print out on terminal of transport element # on one and the same line
      nrtre = nrtre + 1
      cr = char(13)
      write (6, 8254) nrtre, nrres, cr
8254  format ('Transport element:', i5, '      Accelerating element:', i5, a1, $)
      ! old       IF(IROT1) WRITE(16,1010) PENT1,RAB1,EK1,EK2,APB(1)
      if (ichaes) then
        write (16, *) '***** beam current: ', beamc, ' mA'
      end if
      write (16, 1010) pent1, rab1, ek1, ek2, apb(1)
1010  format ('    ENTRANCE FACE ******', /, '  ANGLE OF POLE FACE ROTATION  ', e12.5, ' DEG', /, &
        '  RADIUS OF CURVATURE          ', e12.5, ' CM', /, '  FRINGE FIELD CORECTIONS K1  K2', 2(2x,e12.5), /, &
        '  VERTICAL HALF-APERTURE       ', e12.5, ' CM')
      write (16, 1020) rmo, devi, baim, nb, bdb
1020  format ('    WEDGE MAGNET************', /, '  BENDING RADIUS:  ', e12.5, ' CM ', /, '  BEND ANGLE:      ', e12.5, &
        ' DEG', /, '  FIELD:           ', e12.5, ' KG', /, '  FIELD GRADIENTS: N ', e12.5, ' BETA:', e12.5)
      ! old       IF(IROT2) WRITE(16,1030) PENT2,RAB2,SK1,SK2,APB(2)
      write (16, 1030) pent2, rab2, sk1, sk2, apb(2)
1030  format ('    EXIT FACE******', /, '  ANGLE OF POLE FACE ROTATION  ', e12.5, ' DEG', /, &
        '  RADIUS OF CURVATURE          ', e12.5, 'CM', /, '  FRINGE FIELD CORRECTIONS K1  K2', 2(2x,e12.5), /, &
        '  VERTICAL HALF-APERTURE       ', e12.5, ' CM')
      ! start prints in file 'short.data'
      idav = idav + 1
      iitem(idav) = 4
      dav1(idav, 2) = devi
      dav1(idav, 3) = rmo*10.
      dav1(idav, 5) = apb(1)*10.
      dav1(idav, 6) = pent1
      dav1(idav, 7) = ek1
      dav1(idav, 8) = ek2
      dav1(idav, 9) = rab1*10.
      dav1(idav, 10) = pent2
      dav1(idav, 11) = sk1
      dav1(idav, 12) = sk2
      dav1(idav, 13) = rab2*10.
      dav1(idav, 14) = nb
      dav1(idav, 15) = bdb
      dav1(idav, 16) = baim*.1
      dav1(idav, 17) = apb(2)*10.
      fh0 = fh/vl
      ! Conversion deg--->rad
      radia = pi/180.
      pent1 = pent1*radia
      devi = devi*radia
      devr = devi
      l = devr*rmo
      dav1(idav, 1) = l*10.
      sdavtot = davtot
      davtot = davtot + l
      dav1(idav, 4) = davtot*10.
      pent2 = pent2*radia
      devtot = devi
      ! ----------------------------
      ! define the bending angle of the synchronous particle over each sector
      devit = devi/float(nsector)
      ! --- devit must be different from pent2
      if (devit==pent2) nsector = nsector + 1
      ! --- space charge computation: nsector must be g.t. 1
      if (ichaes .and. (nsector==1)) nsector = 2
      devi = devi/float(nsector)
      devr = devr/float(nsector)
      ! ----------------------------------------------------------
      ! -- scl effective length for space charge computation
      ! scl is the path length of the C.T. over two following sectors
      scl = 2.*devi*rmo
      ! save pent1 , pent2 , devi, ek1, ek2 ,sk1 , sk2 ,
      pent1s = pent1
      pent2s = pent2
      devis = devi
      devrs = devr
      ek1s = ek1
      ek2s = ek2
      sk1s = sk1
      sk2s = sk2
      ! --------------------
      do ist = 1, ncstat
        xcl2(ist) = 0.
        rmoy(ist) = 0.
        rig(ist) = 0.
        baims(ist) = baim
      end do
      ! -------------------
      ! ---- nsector: number of sectors in the bending magnet
      do nsec = 1, nsector
        ! write(6,*) '********'
        ! write(6,*) ' BENDING MAGNET sector ',nsec
        devi = devis
        devr = devrs
        xlsy = devi*rmo
        sdavtot = sdavtot + xlsy
        if (nsector>1) then
          if (nsec==1) then
            pent1 = pent1s
            pent2 = 0.
            ek1 = ek1s
            ek2 = ek2s
            sk1 = 0.
            sk2 = 0.
          end if
          if (nsec==nsector) then
            pent1 = 0.
            pent2 = pent2s
            ek1 = 0.
            ek2 = 0.
            sk1 = sk1s
            sk2 = sk2s
          end if
          if ((nsec>1) .and. (nsec<nsector)) then
            pent1 = 0.
            pent2 = 0.
            ek1 = 0.0001
            ek2 = 0.
            sk1 = 0.0001
            sk2 = 0.
          end if
        end if
        ! ------------------------------------------------------------
        ! --- nsctat: number of charges in the beam
        do ist = 1, ncstat
          charge(ist) = cstat(ist)
          devi = devis
          devr = devrs
          xcl1(ist) = pent1 - xcl2(ist)
          xmoy(ist) = 0.
          xpmoy(ist) = 0.
          ymoy(ist) = 0.
          ypmoy(ist) = 0.
          ncs(ist) = 0
          rig(ist) = 0.
          sbeta(ist) = 0.
          do i = 1, ngood
            if (f(9,i)==charge(ist)) then
              xmoy(ist) = xmoy(ist) + f(2, i)
              ymoy(ist) = ymoy(ist) + f(4, i)
              xpmoy(ist) = xpmoy(ist) + f(3, i)
              ypmoy(ist) = ypmoy(ist) + f(5, i)
              gpai = f(7, i)/xmat
              bpai = sqrt(1.-1./(gpai*gpai))
              sbeta(ist) = sbeta(ist) + bpai
              xmco = xmat*bpai*gpai
              rip = 33.356*xmco*1.e-01/f(9, i)
              rig(ist) = rip + rig(ist)
              ! old            rmoy(ist)=rmoy(ist)+rip
              ncs(ist) = ncs(ist) + 1
            end if
          end do
          sbeta(ist) = sbeta(ist)/float(ncs(ist))
          xmoy(ist) = xmoy(ist)/float(ncs(ist))
          ymoy(ist) = ymoy(ist)/float(ncs(ist))
          xpmoy(ist) = xpmoy(ist)/float(ncs(ist))
          ypmoy(ist) = ypmoy(ist)/float(ncs(ist))
          rig(ist) = rig(ist)/float(ncs(ist))
          ! old         rmoy(ist)=rig(ist)/baim
          rmoy(ist) = rig(ist)/baims(ist)
          ! eq.14
          ctan = cos(devi-pent2)/sin(devi-pent2)
          xep = rmo*(sin(devi)*ctan-cos(devi))
          xepc = xep + rmo - rmoy(ist) + xmoy(ist)
          ! eq.15 and eq.16
          argu = -xmoy(ist)*tan(pent1)/xepc
          ! eq.16
          omga = atan(argu)
          ! eq.15
          thet = omga + devi - pent2
          ! eq.18
          eo1 = xepc/cos(omga)
          ! eq.17
          arg1 = eo1*sin(thet)/rmoy(ist)
          eta = asin(arg1)
          ! eq.13
          xeb1 = xepc*cos(thet)/cos(omga) + rmoy(ist)*cos(eta)
          sxeb1(ist) = xeb1
          ! eq.12
          xk2b1 = -xmoy(ist)*tan(xcl1(ist)) + xeb1*sin(devi-pent2)
          ! eq.11  (bend angle)
          alp(ist) = asin(xk2b1/rmoy(ist))
          ! eq.18
          xeo1 = xepc/cos(omga)
          ! eq.19 (angle of inclination exit)
          argu = eo1/rmoy(ist)*sin(thet)
          xcl2(ist) = asin(argu)
          sa1b1 = -rmo*sin(devr)
          sa1b1 = sa1b1/sin(devr-pent2)
          xsa1b1(ist) = sa1b1 + sxeb1(ist)
          ! --- field
          ! first order
          baims(ist) = baim*(1.-nb*xsa1b1(ist)/rmo)
          ! second order
          rih = 1./(rmo*rmo)
          baims(ist) = baims(ist) + xb*rih*xsa1b1(ist)*xsa1b1(ist)
          ! -----------------------------------------------------
          ! ----  Transport matrix
          sbet = sbeta(ist)
          devi = alp(ist)
          ailong = devi*rmoy(ist)
          write (16, 101) charge(ist), nsec, nsector, baims(ist), xsa1b1(ist), rmoy(ist), devi*180./pi, ailong, rig(ist)
101       format (/, '  **************************************', /, '  *CENTRAL TRAJECTORY for charge: ', f4.1, ' *', /, &
            '  **************************************', /, '  SECTOR: ', i4, ' SECTORS NUMBER: ', i5, /, &
            '  BENDING FIELD:   ', e12.5, ' kG  at: ', e12.5, ' cm', /, '  BENDING RADIUS:  ', e12.5, ' CM ', /, &
            '  BENDING ANGLE:   ', e12.5, ' DEG', /, '  length: ', e12.5, ' cm  rigidity: ', e12.5, ' kG.cm')
          l = ailong
          h = 1./rmoy(ist)
          ! ENTRANCE FACE OF THE BENDING MAGNET
          ! CLEAR R AND T
          call clear
          gap = apb(1)
          be = xcl1(ist)
          layl = ek1
          layx = ek2
          rabt = 0.
          if (abs(rab1)>6.*0) rabt = 1./rab1
          ! -----------------------------------------
          gcog = 0.
          nii = 0
          do ii = 1, ngood
            if (f(9,ii)==charge(ist)) then
              gcog = gcog + f(7, ii)/xmat
              nii = nii + 1
            end if
          end do
          gcog = gcog/float(nii)
          bcog = sqrt(1.-1./(gcog*gcog))
          fdtot = 0.
          do ii = 1, ngood
            if (f(9,ii)==charge(ist)) then
              tbe = tan(be)
              f(2, ii) = f(2, ii) - xmoy(ist)
              gpai = f(7, ii)/xmat
              bpai = sqrt(1.-1./(gpai*gpai))
              f(6, ii) = f(6, ii) + xmoy(ist)*tbe/(bpai*vl)
              fd(ii) = (gpai*bpai)/(gcog*bcog)
              fdtot = fdtot + fd(ii)
            end if
          end do
          ! TEST
          fdtot = fdtot/float(nii) - 1.
          ! --------------------------------------------------
          call pofar1(gap)
          write (16, 4502) be*180./pi, charge(ist)
4502      format ('  ****INPUT FACE*** SLOPE: ', e12.5, ' deg ', 'CHARGE: ', f4.1)
          call matrix
          xll = 0.
          do ii = 1, ngood
            if (f(9,ii)==charge(ist)) then
              call cobeam(ii, xll)
            end if
          end do
          ! *******************************************************
          ! WEDGE BENDING MAGNET
          ! CLEAR R AND T
          call clear
          call benmag(sbet, fdtot)
          ! ---  :print the transport matrix
          write (16, 4101) charge(ist)
4101      format ('  ****BENDING MAGNET for charge ', f4.1)
          call matrix
          r51 = r(5, 1)
          ! ----  transport of particles
          do ii = 1, ngood
            if (f(9,ii)==charge(ist)) then
              call cobeam(ii, l)
            end if
            ! synchrotron radiation (only for electrons, i.e. erest = 0.511 Mev)
            if (iraysh .and. xmat==0.511) call syrout(ii)
          end do
          ! *******************************************************
          ! --- EXIT FACE OF THE BENDING MAGNET
          ! CLEAR R AND T
          call clear
          xll = 0.
          gap = apb(2)
          be = xcl2(ist)
          layl = sk1
          layx = sk2
          rabt = 0.
          if (abs(rab2)>1.e-10) rabt = 1./rab2
          call pofar2(gap)
          ! ---- :print the transport matrix
          write (16, 4501) be*180./pi, charge(ist)
4501      format ('  ****EXIT FACE*** SLOPE: ', e12.5, ' deg CHARGE: ', f4.1)
          call matrix
          ! transport of particles
          xll = 0.
          do ii = 1, ngood
            if (f(9,ii)==charge(ist)) then
              call cobeam(ii, xll)
            end if
          end do
          ! -------------------------------------------------------------------------
          ! --- get back the particles coordinates in the coordinates system of the synchronous particle
          sa1b1 = -rmo*sin(devr)
          sa1b1 = sa1b1/sin(devr-pent2)
          ttt = xcl2(ist) - pent2
          ttt = ttt*1.e03
          do ii = 1, ngood
            if (f(9,ii)==charge(ist)) then
              ! EQ.29
              a1b1 = sa1b1 + sxeb1(ist)
              ! EQ.28
              f(2, ii) = (a1b1+f(2,ii)/cos(xcl2(ist)))*cos(pent2)
              ! EQ.30
              f(3, ii) = f(3, ii) - ttt
              ! EQ.31
              gpai = f(7, ii)/xmat
              bpai = sqrt(1.-1./(gpai*gpai))
              f(6, ii) = f(6, ii) + r51*xmoy(ist)/(bpai*vl)
              ! cc              f(6,ii)=f(6,ii)-r51*xmoy(ist)/(bpai*vl)
              ! **** allow plotting the beam after the sector number nsprint in file 13 (see the MAIN)
              ! cc            if(nsec.eq.nsprint) then
              ! cc       write(13,2587) nsec,ist,charge(ist),f(2,ii),f(3,ii),f(4,ii),
              ! cc     *                   f(5,ii),xmoy(ist),ymoy(ist),rmoy(ist)
              ! cc2587   format(2x,i3,2x,i3,8(2x,e12.5))
              ! cc            endif
              ! ***************************************************************************
            end if
          end do
          ! enddo for ist (number of charges in the beam)
        end do
        ! --------------------------------------------------------------
        ! Space charge computation
        if (ichaes) then
          ! --- check the parity of nsec
          pnsec = float(nsec)/2. - nsec/2
          ! nsec is odd:---> space charge computation
          if ((pnsec/=0.) .and. (nsec<nsector)) then
            call cesp(scl)
            write (16, *) ' space charge after sector: ', nsec
          end if
        end if
        ! ------------------------------------------------------------
        ! synchronous radiation (only for electrons i.e. erest = 0.511 Mev)
        if (iraysh .and. xmat==0.511) call syref
        ! The routine SYREF changes vref and tref (reference)
        ! envelope
        call stapl(sdavtot*10.)
        ! enddo for nsec (sectors numbers)
      end do
      ! ------------------------------------------------------
      ! random error in alignment
      if (ialin) call randali
      ! Change the dispersion dE/E with respect to the C.O.G of the bunch
      call disp
      call cogetc
      ! --- Test window after the bending magnet
      tcog = 0.
      gcog = 0.
      do i = 1, ngood
        gcog = gcog + f(7, i)/xmat
        tcog = tcog + f(6, i)
      end do
      tcog = tcog/float(ngood)
      gcog = gcog/float(ngood)
      bcog = sqrt(1.-1./(gcog*gcog))
      wcg = (gcog-1.)*xmat
      ! devtot: total angle of the bending magnet(computation of tref)
      devi = devtot
      ailong = devi*rmo
      if (iraysh .and. xmat==0.511) go to 2561
      tref = tref + ailong/vref
      ! ----- window control
      call reject(ilost)
      ! ---------------------------------------------------
      dav1(idav, 37) = ngood
      if (itvol) ttvols = tref
2561  continue
      beref = vref/vl
      gamref = 1./sqrt(1.-beref*beref)
      xmco = xmat*beref*gamref
      boro = 33.356*xmco*1.e-01/qst
      tlong = tref*vref
      write (16, 256) beref, gamref, tref, tlong, boro, ngood
256   format (//, 3x, ' *** REFERENCE AT THE EXIT :', /, '   BETA :', e12.5, ' GAMMA :', e12.5, /, '   T.O.F (SEC): ', &
        e12.5, '   T.O.F (CM): ', e12.5, /, '   RIGIDITY(KGAUSS.CM) :', e12.5, /, '   NUMBER OF PARTICLES :', i6, /)
      if (itvol) write (16, *) ' tof for adjustments: ', ttvols, ' sec'
      if (iemgrw) call emiprt(0)
      ! old       CALL STAPL(davtot*10.)
      return
    end subroutine aimalv
    ! *******************************************************************
    ! SUBROUTINE deflect(fdtot)
    ! Electrostatic deflector: Transport matrix
    ! first order transport matrix (M,RD)
    ! drad: horizontal deflector radius (cm)
    ! l: length of the central trajectory (cm)
    ! kx2, ky2: matrix terms arguments (cm-2)
    ! avb: average relativistic beta
    ! in this routine drad, l kx2, ky2 are converted to m
    ! With matrix elements from F.Hinterberger to Triumf note TRI-DN-05-7
    ! *******************************************************************
    subroutine deflect(fdtot)
      implicit real *8(a-z)
      common /bloc11/r(6, 6), t(6, 6, 6)
      common /edef/avb, drad, kx2, ky2, l
      ! --- convert drad, kx2 , ky2 in m
      h = 100./drad
      h2 = h*h
      al = l*1.e-02
      kx2 = kx2*1.e04
      ky2 = ky2*1.e04
      kx = sqrt(abs(kx2))
      ky = sqrt(abs(ky2))
      argx = kx*al
      argy = ky*al
      avb2 = avb*avb
      avg = sqrt(1.-avb2)
      avg = 1./avg
      avg2 = avg*avg
      dx = (2.-avb2)*h/kx
      dxp = (2.-avb2)*h/kx2
      ! ***** variante:(???)
      ! dx=h/kx
      ! dxp=h/kx2
      ! ************************
      ! kx2 < 0
      if (kx2<6.*0) then
        cx = cosh(argx)
        sx = sinh(argx)/kx
        sxp = sinh(argx)*kx
        ! ---------------------------------
        ! First order Matrix R (plane (X,XP)
        r(1, 1) = cx
        r(1, 2) = sx
        r(1, 6) = dxp*(1.-cx)
        r(2, 1) = sxp
        r(2, 2) = cx
        r(2, 6) = dx*sx*kx
        r(5, 1) = -dx*sx*kx
        r(5, 2) = -dxp*(1.-cx)
        r(5, 5) = 1.
        r(5, 6) = fdtot*al/avg2 - (2.-avb2)*dxp*h*(al-sx)
        r(6, 6) = 1.
      end if
      ! kx2 > 0
      if (kx2>6.*0) then
        cx = cos(argx)
        sx = sin(argx)/kx
        sxp = sin(argx)*kx
        ! First order Matrix R (plane (X,XP)
        r(1, 1) = cx
        r(1, 2) = sx
        r(1, 6) = dxp*(1.-cx)
        r(2, 1) = -sxp
        r(2, 2) = cx
        r(2, 6) = dx*sx*kx
        r(5, 1) = dx*sx*kx
        r(5, 2) = dxp*(1.-cx)
        r(5, 5) = 1.
        r(5, 6) = fdtot*al/avg2 - (2.-avb2)*dxp*h*(al-sx)
        r(6, 6) = 1.
      end if
      ! kx2 = 0
      if (kx2==6.*0) then
        r(1, 1) = 1.
        r(1, 2) = al
        r(1, 6) = 0.
        r(2, 1) = 0.
        r(2, 2) = 1.
        r(2, 6) = l*h*(2.-avb2)
        r(5, 1) = -l*h*(2.-avb2)
        r(5, 2) = 0.
        r(5, 5) = 1.
        r(5, 6) = al/avg2
      end if
      ! ky2 < 0
      if (ky2<6.*0) then
        cy = cosh(argy)
        sy = sinh(argy)/ky
        syp = sinh(argy)*ky
        r(3, 3) = cy
        r(3, 4) = sy
        r(4, 3) = syp
        r(4, 4) = cy
      end if
      ! ky2 > 0
      if (ky2>6.*0) then
        cy = cos(argy)
        sy = sin(argy)/ky
        syp = sin(argy)*ky
        r(3, 3) = cy
        r(3, 4) = sy
        r(4, 3) = -syp
        r(4, 4) = cy
      end if
      ! ky2 = 0
      if (ky2==6.*0) then
        cy = 1.
        sy = al
        syp = 0.
        r(3, 3) = cy
        r(3, 4) = sy
        r(4, 3) = syp
        r(4, 4) = cy
      end if
      return
    end subroutine deflect
    ! *******************************************************************
    ! SUBROUTINE e_deflec
    ! characteristics of the deflector (central trajectory)
    ! input parameters
    ! nsector: nombre of sectors in the deflector
    ! rm0: radial radius (cm)
    ! devtot: bend angle (deg)
    ! radii: vertical (radial) radii of curvature (cm)
    ! elecf: nominal electric field
    ! characteristics of the synchronous particle
    ! wt0 :total energy (MeV)
    ! qst: electric charge
    ! *******************************************************************
    subroutine e_deflec
      implicit real *8(a-h, o-z)
      parameter(iptsz=100002, maxcell=3000, maxcell1=3000)
      common /ttfc/tk, t1k, t2k, sk, s1k, s2k, fh
      common /sc3/beamc, scdist, sce10, cplm, ect, apl, ichaes, iscsp
      common /fene/wdisp, wphas, wx, wy, rlim, ifw
      common /davcom/dav1(maxcell1, 40), davtot, iitem(maxcell1), idav
      common /tapes/in, ifile, meta
      common /dyn/tref, vref
      common /erigid/edr0
      common /faisc/f(10, iptsz), imax, ngood
      common /femt/iemgrw, iemqesg
      logical iemgrw
      common /etcom/cog(8), exten(17), fd(iptsz)
      common /qmoyen/qmoy
      common /consta/vl, pi, xmat, rpel, qst
      common /edef/avb, drad, kx2, ky2, l
      real *8 l, kx2, ky2
      common /bloc11/r(6, 6), t(6, 6, 6)
      common /pltprf/sprfx(3000), sprfy(3000), sprfl(3000), sprfw(3000), sprfp(3000), sprng(3000), iprf
      common /rander/ialin
      common /cgtof/charm(20), cgtdv(20), nbch(20), netac
      common /compt/nrres, nrtre, nrbunc, nrdbun
      common /itvole/itvol, imamin
      common /tofev/ttvols
      common /secdr/iseor
      logical iseor, sseor
      common /mcs/imcs, ncstat, cstat(20)
      logical itvol, imamin, ichaes
      character *1 cr
      logical ialin
      dimension xmoy(20), ymoy(20), rmoy(20), rig(20), ncs(20)
      dimension xpmoy(20), ypmoy(20), avbt(20), charge(20), alp(20)
      ! -----------------------------------------------------------------
      ! print out on terminal of transport element # on one and the same line
      nrtre = nrtre + 1
      cr = char(13)
      write (6, 8254) nrtre, nrres, cr
8254  format ('Transport element:', i5, '      Accelerating element:', i5, a1, $)
      ! ---- save iseor in sseor
      sseor = iseor
      ! iseor = false ---> second ordre transport matrix not available for the deflector
      iseor = .false.

      read (in, *) nsector
      read (in, *) rm0, devtot, radii, elecf
      bd0 = vref/vl
      gd0 = sqrt(1.-bd0*bd0)
      gd0 = 1./gd0
      wt0 = gd0*xmat
      wt0c = (wt0-xmat)
      ! edr0: electric rigidity (kV)
      edr0 = wt0*bd0*bd0*1.e03/qst
      ! efd0: radial electric field (in kV/cm)
      efd0 = edr0/rm0
      edfnom = efd0
      if (elecf>=0.) efd0 = elecf
      write (16, 1020) rm0, devtot, radii, edr0, edfnom, efd0, wt0c
1020  format ('    ELECTROSTATIC DEFLECTOR************', /, '  BENDING RADIUS:  ', e12.5, ' cm ', /, &
        '  BEND ANGLE:      ', e12.5, ' deg', /, '  VERTICAL RADII OF CURVATURE: ', e12.5, ' cm', /, '  RIGIDITY: ', &
        e12.5, ' kV ', /, '  RADIAL ELECTRIC FIELD (nominal): ', e12.5, ' kV/cm', /, &
        '  RADIAL ELECTRIC FIELD (applied): ', e12.5, ' kV/cm', /, '  INPUT ENERGY: ', e12.5, ' MeV', /)
      if (ichaes) then
        write (16, *) '***** beam current: ', beamc, ' mA'
        if ((iscsp<3) .and. (ncstat>1)) then
          write (6, *) '****************************'
          write (6, 2748)
2748      format (' CAUTION: In the case of multiple charge states', /, &
            ' HERSC and SCHERM can not be used for electrostatic bends')
        end if
      end if
      ! start prints in file 'short.data'
      findex = 1. + rm0/radii
      idav = idav + 1
      iitem(idav) = 21
      dav1(idav, 2) = devtot
      dav1(idav, 3) = rm0*10.
      dav1(idav, 5) = radii*10.
      dav1(idav, 6) = findex
      dav1(idav, 7) = edr0
      dav1(idav, 8) = efd0*0.1
      ! convert bend angle in rad
      devtot = devtot*pi/180.
      l = devtot*rm0
      dav1(idav, 1) = l*10.
      sdavtot = davtot
      davtot = davtot + l
      dav1(idav, 4) = davtot*10.
      ! --- space charge computation: nsector must be g.t. 1
      if (ichaes .and. (nsector==1)) nsector = 2
      devi = devtot/float(nsector)
      devr = devtot/float(nsector)
      ! ----------------------------------------------------------
      ! -- scl effective length for space charge computation
      ! scl is the path length of the C.T. over two following sectors
      scl = 2.*devi*rm0
      do ist = 1, ncstat
        rmoy(ist) = 0.
        rig(ist) = 0.
        alp(ist) = devi
      end do
      ! -------------------
      ! ---- nsector: number of sectors in the deflector
      do nsec = 1, nsector
        write (6, *) '********'
        write (6, *) ' deflector sector ', nsec
        xlsy = devi*rm0
        sdavtot = sdavtot + xlsy
        ! ------------------------------------------------------------
        ! --- nsctat: number of charge states in the beam
        do ist = 1, ncstat
          charge(ist) = cstat(ist)
          xmoy(ist) = 0.
          xpmoy(ist) = 0.
          ymoy(ist) = 0.
          ypmoy(ist) = 0.
          ncs(ist) = 0
          rig(ist) = 0.
          avbt(ist) = 0.
          do i = 1, ngood
            if (f(9,i)==charge(ist)) then
              xmoy(ist) = xmoy(ist) + f(2, i)
              ymoy(ist) = ymoy(ist) + f(4, i)
              xpmoy(ist) = xpmoy(ist) + f(3, i)
              ypmoy(ist) = ypmoy(ist) + f(5, i)
              gpai = f(7, i)/xmat
              bpai = sqrt(1.-1./(gpai*gpai))
              avbt(ist) = avbt(ist) + bpai
              ! electric rigidity (kV)
              rip = f(7, i)*bpai*bpai/f(9, i)*1.e03
              rig(ist) = rip + rig(ist)
              ncs(ist) = ncs(ist) + 1
            end if
          end do
          xmoy(ist) = xmoy(ist)/float(ncs(ist))
          ymoy(ist) = ymoy(ist)/float(ncs(ist))
          xpmoy(ist) = xpmoy(ist)/float(ncs(ist))
          ypmoy(ist) = ypmoy(ist)/float(ncs(ist))
          rig(ist) = rig(ist)/float(ncs(ist))
          rmoy(ist) = rig(ist)/efd0
          avbt(ist) = avbt(ist)/float(ncs(ist))
          ! dispersion in dp/p relative to the cog of the bunch
          gcog = sqrt(1.-avbt(ist)*avbt(ist))
          fdtot = 0.
          nii = 0
          do i = 1, ngood
            if (f(9,i)==charge(ist)) then
              gpai = f(7, i)/xmat
              bpai = sqrt(1.-1./(gpai*gpai))
              fd(i) = (gpai*bpai)/(gcog*avbt(ist))
              fdtot = fdtot + fd(i)
              nii = nii + 1
            end if
          end do
          fdtot = fdtot/float(nii)
          ! --- local deflector
          ! alp(ist): angle of the local deflector
          ! parametres kx2 and ky2
          ! eq.11
          oo1 = rm0 - rmoy(ist) + xmoy(ist)
          ! eq.10
          abet = oo1*sin(alp(ist))/rmoy(ist)
          abet = asin(abet)
          ! eq.12 (angle of the local central trajectory)
          alp(ist) = alp(ist) + abet
          ! eq.14 (field index)
          findex = 1. + rmoy(ist)/radii
          ! eq.15 (parameters kx, ky)
          kx2 = 3. - findex - avbt(ist)*avbt(ist)
          rmoy2 = rmoy(ist)*rmoy(ist)
          kx2 = kx2/rmoy2
          ky2 = (findex-1.)/rmoy2
          ! ----  Transport matrix
          devi = alp(ist)
          ailong = devi*rmoy(ist)
          l = ailong
          ! drad: horizontal deflector radius (cm)
          ! l: length of the central trajectory (cm)
          ! kx2, ky2: DIMENSIONLESS coefficients depending on the field indice
          ! avb: average relativistic beta
          avb = avbt(ist)
          drad = rmoy(ist)
          ! --- deflector matrix
          write (16, 4101) charge(ist), nsec, nsector, efd0, rig(ist), findex, kx2, ky2, rmoy(ist), devi*180./pi, ailong
4101      format (/, '  **************************************', /, '  *CENTRAL TRAJECTORY for charge: ', f4.1, ' *', /, &
            '  **************************************', /, '  SECTOR: ', i4, ' SECTORS NUMBER: ', i5, /, &
            '  RADIAL FIELD:   ', e12.5, ' kV*cm-1: ', /, '  RIGIDITY:   ', e12.5, ' kV ', /, '  FIELD INDEX: ', e12.5, &
            ' PARAMETER Kx: ', e12.5, ' cm-2  PARAMETER Ky: ', e12.5, ' cm-2', /, '  BENDING RADIUS:  ', e12.5, ' cm ', &
            '  BENDING ANGLE:   ', e12.5, ' deg', /, '  LENGTH: ', e12.5, ' cm', /)
          ! CLEAR R AND T
          call clear
          call deflect(fdtot)
          ! ---  :print the transport matrix
          call matrix
          r51 = r(5, 1)
          ! ----  transport of particles
          do ii = 1, ngood
            if (f(9,ii)==charge(ist)) then
              call cobeam(ii, l)
            end if
          end do
          ! -------------------------------------------------------------------------
          ! --- get back the particles coordinates in the coordinates system of the synchronous particle
          ! eq.33
          ec = -rmoy(ist)*cos(abet) - oo1*sin(devi) + rm0
          do ii = 1, ngood
            if (f(9,ii)==charge(ist)) then
              ! eq.36
              f(2, ii) = f(2, ii)*cos(abet) - ec
              ! eq.41
              f(3, ii) = f(3, ii) - abet*1.e03
              ! eq.45
              gpai = f(7, ii)/xmat
              bpai = sqrt(1.-1./(gpai*gpai))
              f(6, ii) = f(6, ii) + r51*xmoy(ist)/(bpai*vl)
            end if
          end do
          ! enddo for ist (number of charges in the beam)
        end do
        ! --------------------------------------------------------------
        ! Space charge computation
        if (ichaes) then
          ! --- check the parity of nsec
          pnsec = float(nsec)/2. - nsec/2
          ! nsec is odd:---> space charge computation
          if ((pnsec/=0.) .and. (nsec<nsector)) then
            call cesp(scl)
            write (6, *) ' space charge after sector: ', nsec
          end if
        end if
        ! ------------------------------------------------------------
        ! enveloppe
        call stapl(sdavtot*10.)
        ! enddo for nsec (sectors numbers)
      end do
      ! ------------------------------------------------------
      ! random error in alignment
      if (ialin) call randali
      ! Change the dispersion dE/E with respect to the C.O.G of the bunch
      call disp
      call cogetc
      ! --- Test window after the bending magnet
      tcog = 0.
      gcog = 0.
      do i = 1, ngood
        gcog = gcog + f(7, i)/xmat
        tcog = tcog + f(6, i)
      end do
      tcog = tcog/float(ngood)
      gcog = gcog/float(ngood)
      bcog = sqrt(1.-1./(gcog*gcog))
      wcg = (gcog-1.)*xmat
      ! devtot: total angle of the deflector (computation of tref)
      devi = devtot
      ailong = devi*rm0
      tref = tref + ailong/vref
      ! ----- window control
      call reject(ilost)
      ! ---------------------------------------------------
      dav1(idav, 36) = ngood
      if (itvol) ttvols = tref
      if (itvol) write (16, *) ' tof for adjustments: ', ttvols, ' sec'
      if (iemgrw) call emiprt(0)
      ! old       CALL STAPL(davtot*10.)
      ! ---- restore iseor (from sseor)
      iseor = sseor
      return
    end subroutine e_deflec
    ! *******************************************************************
    ! SUBROUTINE cesp(xlqua)
    ! select the space charge method (optical lenses)
    ! *******************************************************************
    subroutine cesp(xlqua)
      implicit real *8(a-h, o-z)
      parameter(iptsz=100002, maxcell=3000, maxcell1=3000)
      common /sc3/beamc, scdist, sce10, cplm, ect, apl, ichaes, iscsp
      common /cdek/dwp(iptsz)
      common /dcspa/iesp
      common /faisc/f(10, iptsz), imax, ngood
      common /mcs/imcs, ncstat, cstat(20)
      logical ichaes, iesp, isepa

      do i = 1, ngood
        dwp(i) = 0.
      end do
      ! Space charge
      scdist = 0.
      if (.not. ichaes) return
      ! XLQUA: length of space charge effect
      if ((iscsp/=3) .and. (ncstat>1)) then
        write (6, *) '****************************'
        write (6, 2748)
2748    format (' ERROR: Wrong space charge model chosen', /, ' With multiple charge states in the beam', /, &
          ' only the SCHEFF routine should be used')
        write (16, 2748)
        stop
      end if
      scdist = xlqua
      write (16, *) 'space charge length(cm): ', scdist
      iesp = .true.
      if (iscsp<=1) then
        ini = 1
        call hersc(ini)
        ini = 2
        call hersc(ini)
      end if
      if (iscsp==2) call schermi
      if (iscsp==3) then
        if (ncstat==1) call scheff1(1)
        ! --- otherwise: ncstat > 1 check if the bunches are separated or not
        if (ncstat>1) then
          isepa = .false.
          call b_sep(isepa)
          ! isepa = true  call special scheff --->scheff_sep
          ! isepa = false call usual scheff ----> scheff1(1)
          if (isepa) call scheff_sep
          if (.not. isepa) call scheff1(1)
        end if
      end if
      return
    end subroutine cesp
    ! *******************************************************************
    ! SUBROUTINE sizer(ist,xrms,yrms,zrms)
    ! partial R.M.S. (called by SCHEFF_sep)
    ! *******************************************************************
    subroutine sizer(ist, xrms, yrms, zrms)
      implicit real *8(a-h, o-z)
      parameter(iptsz=100002, maxcell=3000, maxcell1=3000)
      common /part/xc(iptsz), yc(iptsz), zc(iptsz)
      common /cgrms/xsum, ysum, zsum
      common /faisc/f(10, iptsz), imax, ngood
      common /mcs/imcs, ncstat, cstat(20)

      xsum = 0.
      ysum = 0.
      zsum = 0.
      xsqsum = 0.
      ysqsum = 0.
      zsqsum = 0.
      ngist = 0
      do i = 1, ngood
        if (f(9,i)==cstat(ist)) then
          ngist = ngist + 1
          xsum = xsum + xc(i)
          ysum = ysum + yc(i)
          zsum = zsum + zc(i)
          xsqsum = xsqsum + xc(i)*xc(i)
          ysqsum = ysqsum + yc(i)*yc(i)
          zsqsum = zsqsum + zc(i)*zc(i)
        end if
      end do
      xsum = xsum/float(ngist)
      ysum = ysum/float(ngist)
      zsum = zsum/float(ngist)
      xsqsum = xsqsum/float(ngist)
      ysqsum = ysqsum/float(ngist)
      zsqsum = zsqsum/float(ngist)
      xrms = sqrt(xsqsum-xsum*xsum)
      yrms = sqrt(ysqsum-ysum*ysum)
      zrms = sqrt(zsqsum-zsum*zsum)
      return
    end subroutine sizer
    ! *******************************************************************
    ! SUBROUTINE pintim1(ist)
    ! Shifts particle coordinates to a single point in time. Uses
    ! a linear shift
    ! Divide by 100. to convert from cm to meters
    ! called by SCHEFF or SCHERM
    ! *******************************************************************
    subroutine pintim1(ist)
      implicit real *8(a-h, o-z)
      parameter(iptsz=100002, maxcell=3000, maxcell1=3000)
      common /faisc/f(10, iptsz), imax, ngood
      common /qmoyen/qmoy
      common /part/xc(iptsz), yc(iptsz), zc(iptsz)
      common /consta/vl, pi, xmat, rpel, qst
      common /sc3/beamc, scdist, sce10, cplm, ect, apl, ichaes, iscsp
      common /azlist/icont, iprin
      common /mcs/imcs, ncstat, cstat(20)

      grmoy = 0.
      trmoy = 0.
      xbax = 0.
      ngist = 0
      do i = 1, ngood
        if (f(9,i)==cstat(ist)) then
          ngist = ngist + 1
          grmoy = grmoy + f(7, i)/xmat
          trmoy = trmoy + f(6, i)
          xbax = xbax + f(2, i)
        end if
      end do
      trmoy = trmoy/float(ngist)
      grmoy = grmoy/float(ngist)
      brmoy = sqrt(1.-1./(grmoy*grmoy))
      xbax = xbax/float(ngist)
      ! ccc       apl=0.
      ! Isochronism correction  (bending magnet) only with SCHERM
      ! does not work with  with SCHEFF  (iscsp=3)
      ! ccc       if(iscsp.eq.2) then
      ! ccc         xb2x=0.
      ! ccc         xb2z=0.
      ! ccc         xbxz=0.
      ! ccc         do np=1,ngood
      ! ccc           gpai=f(7,np)/xmat
      ! ccc           bpai=sqrt(1.-1./(gpai*gpai))
      ! ccc           zc(np)=(trmoy-f(6,np))*bpai*vl/100.
      ! ccc           xc(np)=(f(2,np)-xbax)/100.
      ! ccc           xb2z=xb2z+zc(np)*zc(np)
      ! ccc           xb2x=xb2x+xc(np)*xc(np)
      ! ccc           xbxz=xbxz+zc(np)*xc(np)
      ! ccc         enddo
      ! ccc         xb2z=xb2z/float(ngood)
      ! ccc         xb2x=xb2x/float(ngood)
      ! ccc         xbxz=xbxz/float(ngood)
      ! ccc         apl=atan(-2.*xbxz/(xb2x-xb2z))/2.
      ! ccc         write(16,*) 'slope of the bunch in plane(Oz,Ox):',apl,' radian'
      ! ccc       endif
      do np = 1, ngood
        if (f(9,np)==cstat(ist)) then
          gpai = f(7, np)/xmat
          bpai = sqrt(1.-1./(gpai*gpai))
          ! iscsp = 3 Lorentz transformation (only with scheff)
          ! omment         if(iscsp.eq.3) znp=(trmoy-f(6,np))*bpai*vl*grmoy
          ! omment         if(iscsp.eq.2) znp=(trmoy-f(6,np))*bpai*vl
          znp = (trmoy-f(6,np))*bpai*vl
          xnp = f(2, np)
          zc(np) = znp*cos(apl) + xnp*sin(apl)
          xnp = xnp*cos(apl) - znp*sin(apl)
          ! convert from mrad to rad
          f3 = f(3, np)*1.e-03
          f5 = f(5, np)*1.e-03
          ! convert from cm   to m
          xc(np) = (xnp+zc(np)*f3)/100.
          yc(np) = (f(4,np)+zc(np)*f5)/100.
          zc(np) = zc(np)/100.
        end if
      end do
      xbar = 0.
      ybar = 0.
      zbar = 0.
      do np = 1, ngood
        ! evaluate xbar , ybar , zbar
        if (f(9,np)==cstat(ist)) then
          xbar = xbar + xc(np)
          ybar = ybar + yc(np)
          zbar = zbar + zc(np)
        end if
      end do
      xbar = xbar/float(ngist)
      ybar = ybar/float(ngist)
      zbar = zbar/float(ngist)
      ! Translate distribution by center of mass coordinates to shift
      ! coordinate origin to (0,0,0)
      do np = 1, ngood
        if (f(9,np)==cstat(ist)) then
          xc(np) = xc(np) - xbar
          yc(np) = yc(np) - ybar
          zc(np) = zc(np) - zbar
        end if
      end do
      return
    end subroutine pintim1
    ! *******************************************************************
    ! SUBROUTINE b_sep(isepa)
    ! check if the bunches in the beam are separated or not
    ! *******************************************************************
    subroutine b_sep(isepa)
      implicit real *8(a-h, o-z)
      parameter(iptsz=100002, maxcell=3000, maxcell1=3000)
      common /part/xc(iptsz), yc(iptsz), zc(iptsz)
      common /cgrms/xsum, ysum, zsum
      common /faisc/f(10, iptsz), imax, ngood
      common /mcs/imcs, ncstat, cstat(20)
      common /consta/vl, pi, xmat, rpel, qst
      dimension d11(2), d22(2), d12(2), rp12(2), xpint(2), xint(2)
      logical isepa

      csmax1 = 0.
      icms1 = 0
      do i = 1, ncstat
        if (cstat(i)>csmax1) then
          icsm1 = i
          csmax1 = cstat(i)
        end if
      end do
      csmax2 = 0.
      do i = 1, ncstat
        if (i/=icsm1) then
          if (cstat(i)>csmax2) then
            csmax2 = cstat(i)
          end if
        end if
      end do
      xg1 = 0.
      xpg1 = 0.
      xg2 = 0.
      xpg2 = 0.
      imax1 = 0
      imax2 = 0
      ! COG over state charges csmax1 and csmax2
      do i = 1, ngood
        if (f(9,i)==csmax1) then
          xg1 = xg1 + f(2, i)
          xpg1 = xpg1 + f(3, i)
          imax1 = imax1 + 1
        end if
        if (f(9,i)==csmax2) then
          xg2 = xg2 + f(2, i)
          xpg2 = xpg2 + f(3, i)
          imax2 = imax2 + 1
        end if
      end do
      xg1 = xg1/float(imax1)
      xpg1 = xpg1/float(imax1)
      xg2 = xg2/float(imax2)
      xpg2 = xpg2/float(imax2)
      ! ------------------------------------
      d11(1) = 0.
      d22(1) = 0.
      d12(1) = 0.
      d11(2) = 0.
      d22(2) = 0.
      d12(2) = 0.
      do i = 1, ngood
        if (f(9,i)==csmax1) then
          d11(1) = d11(1) + (f(3,i)-xpg1)**2
          d22(1) = d22(1) + (f(2,i)-xg1)**2
          d12(1) = d12(1) + (f(3,i)-xpg1)*(f(2,i)-xg1)
        end if
        if (f(9,i)==csmax2) then
          d11(2) = d11(2) + (f(3,i)-xpg2)**2
          d22(2) = d22(2) + (f(2,i)-xg2)**2
          d12(2) = d12(2) + (f(3,i)-xpg2)*(f(2,i)-xg2)
        end if
      end do
      d11(1) = d11(1)/float(imax1)
      d22(1) = d22(1)/float(imax1)
      d12(1) = d12(1)/float(imax1)
      d11(2) = d11(2)/float(imax2)
      d22(2) = d22(2)/float(imax2)
      d12(2) = d12(2)/float(imax2)
      rp12(1) = d12(1)/sqrt(d11(1)*d22(1))
      rp12(2) = d12(2)/sqrt(d11(2)*d22(2))
      xpint(1) = sqrt(d11(1)*(1.-rp12(1)))
      xint(1) = sqrt(d22(1)*(1.-rp12(1)))
      xpint(2) = sqrt(d11(2)*(1.-rp12(2)))
      xint(2) = sqrt(d22(2)*(1.-rp12(2)))
      ! ------------------------------------------------------------
      elip1 = xpg1 + xpint(1)
      elip2 = xpg2 - xpint(2)
      if (elip1<elip2) isepa = .true.
      ! TEST*********
      ! old       write(6,*)'xpg1 xpint(1) elip1 ',xpg1,xpint(1),elip1
      ! old       write(6,*)'xpg2 xpint(2) elip2 ',xpg2,xpint(2),elip2
      ! old       write(6,*)'isepa ',isepa
      ! old       write(6,*) ' ************************************'
      ! ***************************************************************
      return
    end subroutine b_sep
    ! *******************************************************************
    ! SUBROUTINE schefini
    ! Set up field tables for SCHEFF1 and SCHEFF_sep
    ! input data
    ! sce(2)=radial extension in rms multiples
    ! sce(3)=longitudinal extension in rms multiples
    ! sce(4)=no. of radial mesh intervals (le 20)
    ! sce(5)=no. of longitudinal mesh intervals (le 40)
    ! sce(6)=no. of adjacent bunches, applicable for buncher
    ! studies and should be 0 for linac dynamics
    ! sce(7)=distance between adjacent beam pulses in cm
    ! (transport studies); input zero to get (beta*lambda)
    ! default
    ! sce(8)=desactived
    ! sce(9)=option to integrate space charge forces over box
    ! if.eq.0. no integration  see sub gaus for further
    ! explanation.
    ! sce(10) =1 : call in quads,solenoids,accelarating elements
    ! sce(10) =2 : call in drifts,accelarating elements
    ! sce(10) =3 : call at both
    ! standard SCHEFF parameters (see user guide)
    ! sce(2)=4
    ! sce(3)=4
    ! sce(4)=20
    ! sce(5)=40
    ! sce(6)=0
    ! sce(7)=0
    ! sce(9)=0
    ! *******************************************************************
    subroutine schefini
      implicit real *8(a-h, o-z)
      parameter(iptsz=100002, maxcell=3000, maxcell1=3000)
      common /dyn/tref, vref
      common /ttfc/tk, t1k, t2k, sk, s1k, s2k, fh
      common /consta/vl, pi, xmat, rpel, qst
      common /sc3/beamc, scdist, sce10, cplm, ect, apl, ichaes, iscsp
      common /faisc/f(10, iptsz), imax, ngood
      logical ichaes
      ! common modifiés *********************
      common /stsc/beami, wavel, freq, btazero, frrms, fzrms, nr, nz
      common /stsc1/beams, im1, im2, im3, nr1, nz1, nq
      common /fldcom/rp, zp, pl, opt, nip
      ! ***********************************
      common /rcshef/sce(20)
      common /conti/irfqp
      logical irfqp

      gmoy = 0.
      do np = 1, ngood
        gmoy = f(7, np)/xmat + gmoy
      end do
      gmoy = gmoy/float(ngood)
      bgmoy = sqrt(gmoy*gmoy-1.)
      beams = beamc/1000.0
      wavel = 2.*pi*vl/fh
      freq = fh/(2.*pi)
      frrms = sce(2)
      fzrms = sce(3)
      nr = idint(sce(4))
      nz = idint(sce(5))
      nip = idint(sce(6))
      opt = sce(9)
      pl = bgmoy*wavel
      if (irfqp) pl = pl/2.
      ! sce(7)=pulse length, if not beta lambda.(transport studies), units are cm
      if (sce(7)>0.) pl = sce(7)*gmoy
      nr1 = nr + 1
      nz1 = nz + 1
      im1 = nr*nz
      im2 = nr1*nz1
      im3 = nr1*nz
      na = 1
      nb = ngood
      nq = nb - na + 1
      return
    end subroutine schefini
    ! *******************************************************************
    ! SUBROUTINE scheff1(idum)
    ! SCHEFF space charge method
    ! remark: In this version int is a dummy parameter
    ! This version of SCHEFF, starting from Swesson version, has
    ! modifications made to include corrections for relativistic beams.
    ! The dynamics have been modified to transform to the beam rest
    ! frame, calculate the space-charge kicks in this frame, and then
    ! transform back to the lab frame.
    ! input data
    ! sce(1)=beam current in ma.
    ! sce(2)=radial extension in rms multiples
    ! sce(3)=longitudinal extension in rms multiples
    ! sce(4)=no. of radial mesh intervals (le 20)
    ! sce(5)=no. of longitudinal mesh intervals (le 40)
    ! sce(6)=no. of adjacent bunches, applicable for buncher
    ! studies and should be 0 for linac dynamics
    ! sce(7)=distance between adjacent beam pulses in cm
    ! (transport studies); input zero to get (beta*lambda)
    ! default
    ! sce(8)=desactived
    ! sce(9)=option to integrate space charge forces over box
    ! if.eq.0. no integration  see sub gaus for further
    ! explanation.
    ! sce(10) =1 : call in quads,solenoids,accelarating elements
    ! sce(10) =2 : call in drifts,accelarating elements
    ! sce(10) =3 : call at both
    ! standard SCHEFF parameters (see sub schfdyn and user guide)
    ! sce(2)=4
    ! sce(3)=4
    ! sce(4)=20
    ! sce(5)=40
    ! sce(6)=0
    ! sce(7)=0
    ! sce(9)=0
    ! *******************************************************************
    subroutine scheff1(idum)
      implicit real *8(a-h, o-z)
      parameter(iptsz=100002, maxcell=3000, maxcell1=3000)
      common /dyn/tref, vref
      common /cmpte/iell
      common /part/xc(iptsz), yc(iptsz), zc(iptsz)
      common /dimens/zcp(iptsz), xcp(iptsz), ycp(iptsz)
      common /hermt/afxt(22), afyt(22), afzt(22)
      common /ttfc/tk, t1k, t2k, sk, s1k, s2k, fh
      common /consta/vl, pi, xmat, rpel, qst
      common /sc3/beamc, scdist, sce10, cplm, ect, apl, ichaes, iscsp
      common /faisc/f(10, iptsz), imax, ngood
      common /cdek/dwp(iptsz)
      common /beamsa/fs(7, iptsz)
      common /dcspa/iesp
      common /compt/nrres, nrtre, nrbunc, nrdbun
      common /posc/xpsc
      logical ichaes, iesp
      common /bg/bsc, gsc, phis, wsync
      common /stsc/beami, wavel, freq, btazero, frrms, fzrms, nr, nz
      common /stsc1/beams, im1, im2, im3, nr1, nz1, nq
      common /fldcom/rp, zp, pl, opt, nip
      common /spacech1/rm(21), zm(41), rs(20), ers(16800), ezs(16800), ez(861), aa(800), rssq(20), zzs(41), er(861), &
        rss(20), ismax(40), iemax(41)
      common /rcshef/sce(20)
      common /conti/irfqp
      ! ********************************************
      ! v28/04/2015
      common /fcont/ifcont
      logical ifcont
      ! ********************************************
      logical irfqp

      idm = idum
      ! set up field tables with int=0
      ! omment       beami=beamc/1000.0
      ! ********************************************
      ! v28/04/2015
      if (ifcont) then
        pib = 180.
        call compress(pib)
      end if
      ! ********************************************
      gmoy = 0.
      do np = 1, ngood
        gmoy = f(7, np)/xmat + gmoy
      end do
      gmoy = gmoy/float(ngood)
      beami = beams/gmoy
      if (beami==0. .or. scdist==0.) return
      iell = iell + 1
      ! write(16,*) ' *call SCHEFF  ',iell
      call pintim
      ! write(16,*) ' *after pintim '
      call sizrms(0, xrms, yrms, zrms, zz)
      ! write(16,*) ' *after sizrms ',zz
      write (16, 6875) iell, xrms, yrms, zrms
      ! write the size rms in the output file 17
      ! omment       write(17,25) iell,xrms,yrms,zrms
      ! omment25     format(2x,i5,3(2x,e12.5))
6875  format (' Cell ', i4, ' RMS size(m)', e12.5, 2x, e12.5, 2x, e12.5)
      rrms = sqrt(xrms*xrms+yrms*yrms)
      ! change unit: m==>cm
      zrms1 = zrms*100.
      rrms = rrms*100.
      dr = rrms*frrms/float(nr)
      dz = zrms1*fzrms/float(nz)
      rmax = float(nr)*dr
      ! load rm, zm, rs, zs
      rm(1) = 0.0
      do i = 2, nr1
        rm(i) = float(i-1)*dr
        rssq(i-1) = .5*(rm(i-1)**2+rm(i)**2)
        rss(i-1) = 0.5*(rm(i-1)+rm(i))
        rs(i-1) = sqrt(rssq(i-1))
      end do
      zs = .5*dz
      do i = 1, nz1
        zm(i) = float(i-1)*dz
        zzs(i) = zm(i) + zs
      end do
      hl = float(nz)*zs
      ! load ers and ezs
      ! mesh dimensions are in cm. ers and ezs are in 1/cm.
      ! c1, c2 and c3 are in cm., and c4 is in mev-cm.
      ! q=coulombs/point.   (2/pi)*e/(4*pi*epsilon)=572167 cm mev/coul.
      q = beami/(freq*float(nq))
      c1 = 572167.*q/xmat
      l = 0
      do k = 1, nr
        rfac = (rm(k+1)**2-rm(k)**2)*dz/2.
        if (opt==0.) rfac = 1.
        do j = 1, nz
          zp = zm(j+1)
          do i = 1, nr1
            rp = rm(i)
            if (opt==0.) call flds(rs(k), zs, er1, ez1)
            if (opt==0.) go to 35
            call gaus(rm(k), rm(k+1), zm(1), zm(2), opt, er1, ez1)
35          l = l + 1
            ers(l) = c1*er1/rfac
            ! cc       write(16,*) ' ersl ',ers(l),' er1 ',er1,' l ',l
            ! cc       write(16,*) ' rsk ',rs(k),' k ',k,' zs ',zs
            ! cc       pause
            ezs(l) = c1*ez1/rfac
          end do
        end do
      end do
      if (beamc==0. .or. scdist==0.) return
      dz1 = scdist/100.
      dist = scdist
      ! sup       WRITE(16, *) ' fields acting length(cm): ',DIST
      ! evaluate and apply space charge effects.
      ! phimc=phi of mesh center.
      ! Shifts particle coordinates to a single point in time. Uses
      ! a linear shift
      ! Beam c.g.
      xbar = 0.
      ybar = 0.
      zbar = 0.
      brmoy = 0.
      trmoy = 0.
      do np = 1, ngood
        gpai = f(7, np)/xmat
        brmoy = brmoy + sqrt(1.-1./(gpai*gpai))
        trmoy = trmoy + f(6, np)
      end do
      trmoy = trmoy/float(ngood)
      phimc = trmoy*fh
      pbar = phimc
      beta = brmoy/float(ngood)
      gsc = 1./sqrt(1.-beta*beta)
      bg = beta*gsc
      c3 = dist/bg
      c4 = dist*xmat
      ! evaluate ng, xbar, ybar, and pbar.
      c2 = beta*wavel/(2.*pi)
      gmsq = 1. + bg**2
      gam = sqrt(gmsq)
      ! evaluate ng, xbar, ybar
      ng = 0
      xbar = 0.
      ybar = 0.
      xsq = 0.
      ysq = 0.
      do np = 1, ngood
        ng = ng + 1
        x = f(2, np)
        y = f(4, np)
        xf = f(3, np)
        yf = f(5, np)
        xbar = xbar + x
        ybar = ybar + y
        xsq = xsq + x**2
        ysq = ysq + y**2
      end do
      eng = float(ngood)
      xbar = xbar/eng
      ybar = ybar/eng
      ! the mesh center is phi*syn
      xsq = xsq/eng
      ysq = ysq/eng
      epsq = sqrt((xsq-xbar*xbar)/(ysq-ybar*ybar))
      epsqi = 1./epsq
      xfac = 2./(epsq+1.)
      yfac = epsq*xfac
      ! clear and load bins
      ng = 0
      do i = 1, im1
        aa(i) = 0.0
      end do
      do np = 1, ngood
        rsq = (f(2,np)-xbar)**2*epsqi + (f(4,np)-ybar)**2*epsq
        ! i=sqrt(rsq)/dr+1.
        r = sqrt(rsq)
        halfdr = dr*0.5
        i = idint(r/dr+1.0)
        if (i>nr) go to 120
        zph = f(6, np)*fh
        z = -c2*(zph-phimc)
        if (abs(z)>=hl) go to 120
        ! ------distribute charge among adjacent bins.
        ng = ng + 1
        zz = z + hl
        jm1 = idint(zz/dz+1.)
        i1 = i + 1
        ! if (rsq.lt.rssq(i)) i1=i-1
        if (rsq<rss(i)) i1 = i - 1
        if (i1<1) i1 = 1
        if (i1>nr) i1 = nr
        j1 = jm1 + 1
        if (zz<zzs(jm1)) j1 = jm1 - 1
        if (j1<1) j1 = 1
        if (j1>nz) j1 = nz
        a = 1.
        ! if (i1.ne.i) a=(rsq-rssq(i1))/(rssq(i)-rssq(i1))
        if (i1==i) then
          a = 1.
        else
          rdr2 = rsq/dr**2
          sqr = sqrt(4.*rdr2-1.)
          rminsq = (halfdr*(sqr-1.))**2
          rmaxsq = (halfdr*(sqr+1.))**2
          if (i1<i) then
            a = (rmaxsq-rm(i)**2)/(rmaxsq-rminsq)
          else
            a = (rm(i1)**2-rminsq)/(rmaxsq-rminsq)
          end if
        end if
        ! omment         if (r.gt.halfdr)then
        ! omment           rminsq=(r-halfdr)**2
        ! omment           rmaxsq=(r+halfdr)**2
        ! omment           if (i1.lt.i) then
        ! omment             a=(rmaxsq-rm(i)**2)/(rmaxsq-rminsq)
        ! omment           else
        ! omment             a=(rm(i1)**2-rminsq)/(rmaxsq-rminsq)
        ! omment           endif
        ! omment         endif
        b = 1. - a
        cc = 1.
        if (j1/=jm1) cc = (zz-zzs(j1))/(zzs(jm1)-zzs(j1))
        d = 1. - cc
        k = (jm1-1)*nr + i
        aa(k) = aa(k) + a*cc
        k = k + i1 - i
        aa(k) = aa(k) + b*cc
        k = (j1-1)*nr + i
        aa(k) = aa(k) + a*d
        k = k + i1 - i
        aa(k) = aa(k) + b*d
120   end do
      eng = float(ng)
      do j = 1, nz
        l = (j-1)*nr
        k = nr
        do i = 1, nr
          m = l + k
          if (aa(m)<=0.00) then
            k = k - 1
            go to 130
          else
            go to 140
          end if
130       continue
        end do
140     ismax(j) = k
      end do
      ! find iemax for each j
      iemax(1) = 1 + ismax(1)
      do j = 2, nz
        iemax(j) = 1 + max0(ismax(j-1), ismax(j))
      end do
      iemax(nz1) = 1 + ismax(nz)
      ! set er and ez to zero
      do i = 1, im2
        er(i) = 0.0
        ez(i) = 0.0
      end do
      ! sum up fields
      do js = 1, nz
        js1 = js + 1
        ism = ismax(js)
        if (ism==0) go to 220
        do is = 1, ism
          l = (js-1)*nr + is
          a1 = aa(l)
          if (a1==0.) go to 210
          l = (is-1)*im3
          do je = 1, js
            k1 = l + (js-je)*nr1
            n1 = (je-1)*nr1
            iem = iemax(je)
            if (iem<=1) go to 180
            do ie = 1, iem
              n = n1 + ie
              k = k1 + ie
              er(n) = er(n) + a1*ers(k)
              ez(n) = ez(n) - a1*ezs(k)
            end do
180       end do
          do je = js1, nz1
            k1 = l + (je-js1)*nr1
            n1 = (je-1)*nr1
            iem = iemax(je)
            if (iem<=1) go to 200
            do ie = 1, iem
              n = n1 + ie
              k = k1 + ie
              er(n) = er(n) + a1*ers(k)
              ez(n) = ez(n) + a1*ezs(k)
            end do
200       end do
210     end do
220   end do
      ! evaluate and apply impulse
      rrmax = 0.
      zzmax = 0.
      zzmin = 1000.
      npz = 0
      npr = 0
      do np = 1, ngood

        ! Transforming to the bunch reference frame

        dwc = f(7, np) - xmat
        gm1 = dwc/xmat
        ! convert xp an yp from mrad to rad
        f3np = f(3, np)*1.e-03
        f5np = f(5, np)*1.e-03
        ! omment   gm1*(2.+gm1)=(gam-1)*(gam+1)=gam*gam-1=beta*beta*gam*gam
        bgz = sqrt(gm1*(2.+gm1))
        bgx = bgz*f3np
        bgy = bgz*f5np
        gamma = 1. + gm1
        ! Particle momentum in the bunch frame

        bgzstar = gam*(bgz-beta*gamma)

        ! Particle energy in bunch frame

        gstar = gam*(gamma-beta*bgz)

        r = sqrt((f(2,np)-xbar)**2*epsqi+(f(4,np)-ybar)**2*epsq)
        if (r>=rrmax) rrmax = r
        if (r==0.) r = .000001
        xor = (f(2,np)-xbar)*xfac/r
        yor = (f(4,np)-ybar)*yfac/r
        if (r>rmax) then
          npr = npr + 1
          go to 230
        end if
        zph = f(6, np)*fh
        z = -c2*(zph-phimc)
        if (z>=zzmax) zzmax = z
        if (z<zzmin) zzmin = z
        if (abs(z)>hl) then
          npz = npz + 1
          go to 230
        end if
        ! interpolate impulse within mesh.
        rb = r/dr
        i = idint(1.+rb)
        a = rb - float(i-1)
        b = 1. - a
        zb = (z+hl)/dz
        j = idint(1.+zb)
        c = zb - float(j-1)
        d = 1. - c
        l = i + (j-1)*nr1
        m = l + nr1
        cbgr = c3*(d*(a*er(l+1)+b*er(l))+c*(a*er(m+1)+b*er(m)))
        cbgzs = c3*(d*(a*ez(l+1)+b*ez(l))+c*(a*ez(m+1)+b*ez(m)))
        ! *******************
        ! cc         write(14,5755)np,cbgr,cbgzs,c3,a,b,c,d
        ! cc         write(14,5755)np,l,m,er(l+1),er(l),er(m+1),er(m)
        ! cc5755   format(2x,i5,7(2x,e12.5))
        ! cc5755   format(3(2x,i5),4(2x,e12.5))
        ! *******************
        ! different space charge in the bunch (valero)
        cbgr = cbgr*abs(f(9,np))
        cbgzs = cbgzs*abs(f(9,np))
        go to 260
        ! estimate impulse based on point charge at xbar,ybar,pbar.
        ! estimate impulse based on point charge at xbar,ybar,pbar.
230     continue
        d = sqrt(z**2+r**2)
        rod3 = r/d**3
        zod3 = z/d**3
        if (nip==0) go to 250
        ! include neighboring bunches.
        do i = 1, nip
          xi = i
          do j = 1, 2
            s = z + xi*pl
            d = sqrt(s**2+r**2)
            rod3 = rod3 + r/d**3
            zod3 = zod3 + s/d**3
            xi = -xi
          end do
        end do
        ! Evaluate impulse.

250     cbgr = eng*c1*c3*rod3*pi/2.
        cbgzs = eng*c1*c3*zod3*pi/2.
        ! different charges in the bunch (valero)
        cbgr = cbgr*abs(f(9,np))
        cbgzs = cbgzs*abs(f(9,np))

        ! Apply impulse and transform back to lab frame.

260     bgx = bgx + cbgr*xor
        bgy = bgy + cbgr*yor
        pbgzstar = bgzstar
        bgzstar = bgzstar + cbgzs
        gstar = 1. + 0.5*bgzstar**2
        bgzf = gam*(bgzstar+beta*gstar)
        f3 = bgx/bgzf
        f5 = bgy/bgzf
        dww = f(7, np) - xmat
        dws = dww*((gamma+1.)/gamma)*(bgzf-bgz)/bgz
        ! cc         write(14,5755)np,pbgzstar,cbgzs,bgzstar
        ! cc5755   format(2x,i5,3(2x,e12.5))
        ! ********************
        if (.not. iesp) then
          ! load the entrance beam parameters for cavities or gaps
          do js = 1, 7
            f(js, np) = fs(js, np)
          end do
          ! dxp and dyp are the jumps of xp and yp (in rad) at the position dz1*xpsc (in m)
          dxp = f3 - f3np
          dyp = f5 - f5np
          ! correction of xp and yp ( in rad)
          f(3, np) = f(3, np) + dxp*1000.
          f(5, np) = f(5, np) + dyp*1000.
          f(2, np) = f(2, np) - dz1*100.*dxp*xpsc
          f(4, np) = f(4, np) - dz1*100.*dyp*xpsc
          dwp(np) = dws
        else
          f(3, np) = f3*1000.
          f(5, np) = f5*1000.
          f(7, np) = f(7, np) + dws
        end if
      end do
      return
    end subroutine scheff1
    ! *******************************************************************
    ! SUBROUTINE scheff_sep
    ! SCHEFF_sep special space charge method
    ! This version of SCHEFF, starting from Swesson version, has
    ! modifications made to include corrections for relativistic beams.
    ! The dynamics have been modified to transform to the beam rest
    ! frame, calculate the space-charge kicks in this frame, and then
    ! transform back to the lab frame.
    ! input data
    ! sce(1)=beam current in ma.
    ! sce(2)=radial extension in rms multiples
    ! sce(3)=longitudinal extension in rms multiples
    ! sce(4)=no. of radial mesh intervals (le 20)
    ! sce(5)=no. of longitudinal mesh intervals (le 40)
    ! sce(6)=no. of adjacent bunches, applicable for buncher
    ! studies and should be 0 for linac dynamics
    ! sce(7)=distance between adjacent beam pulses in cm
    ! (transport studies); input zero to get (beta*lambda)
    ! default
    ! sce(8)=desactived
    ! sce(9)=option to integrate space charge forces over box
    ! if.eq.0. no integration  see sub gaus for further
    ! explanation.
    ! sce(10) =1 : call in quads,solenoids,accelarating elements
    ! sce(10) =2 : call in drifts,accelarating elements
    ! sce(10) =3 : call at both
    ! standard SCHEFF parameters (see sub schfdyn and user guide)
    ! sce(2)=4
    ! sce(3)=4
    ! sce(4)=20
    ! sce(5)=40
    ! sce(6)=0
    ! sce(7)=0
    ! sce(9)=0
    ! *******************************************************************
    subroutine scheff_sep
      implicit real *8(a-h, o-z)
      parameter(iptsz=100002, maxcell=3000, maxcell1=3000)
      common /dyn/tref, vref
      common /cmpte/iell
      common /part/xc(iptsz), yc(iptsz), zc(iptsz)
      common /dimens/zcp(iptsz), xcp(iptsz), ycp(iptsz)
      common /hermt/afxt(22), afyt(22), afzt(22)
      common /ttfc/tk, t1k, t2k, sk, s1k, s2k, fh
      common /consta/vl, pi, xmat, rpel, qst
      common /sc3/beamc, scdist, sce10, cplm, ect, apl, ichaes, iscsp
      common /faisc/f(10, iptsz), imax, ngood
      common /cdek/dwp(iptsz)
      common /beamsa/fs(7, iptsz)
      common /dcspa/iesp
      common /compt/nrres, nrtre, nrbunc, nrdbun
      common /posc/xpsc
      logical ichaes, iesp
      common /bg/bsc, gsc, phis, wsync
      common /stsc/beami, wavel, freq, btazero, frrms, fzrms, nr, nz
      common /stsc1/beams, im1, im2, im3, nr1, nz1, nq
      common /fldcom/rp, zp, pl, opt, nip
      common /spacech1/rm(21), zm(41), rs(20), ers(16800), ezs(16800), ez(861), aa(800), rssq(20), zzs(41), er(861), &
        rss(20), ismax(40), iemax(41)
      common /rcshef/sce(20)
      common /mcs/imcs, ncstat, cstat(20)
      common /conti/irfqp
      logical irfqp
      ! set up field tables with int=0
      if (beams==0. .or. scdist==0.) return
      ! isepa true ---> the ncstat bunches are separated
      iell = iell + 1
      write (16, *) ' ****SCHEFF  ', iell
      write (16, *) ' states charges ', ncstat
      do isp = 1, ncstat
        ngisp = 0
        gmoy = 0.
        do np = 1, ngood
          if (f(9,np)==cstat(isp)) then
            ngisp = ngisp + 1
            gmoy = f(7, np)/xmat + gmoy
          end if
        end do
        gmoy = gmoy/float(ngisp)
        ! old          beamc=beams/ncstat
        beamc = beams*ngisp/ngood
        beami = beamc/gmoy
        call pintim1(isp)
        call sizer(isp, xrms, yrms, zrms)
        write (16, 6875) cstat(isp), beamc, xrms, yrms, zrms
        ! write the size rms in the output file 17
        ! old       write(17,25) iell,xrms,yrms,zrms
        ! old25     format(2x,i5,3(2x,e12.5))
6875    format (' charge: ', f8.0, ' bunch intensity: ', e12.5, ' amp', /, ' with RMS size(m)', e12.5, 2x, e12.5, 2x, &
          e12.5)
        rrms = sqrt(xrms*xrms+yrms*yrms)
        ! change unit: m==>cm
        zrms1 = zrms*100.
        rrms = rrms*100.
        dr = rrms*frrms/float(nr)
        dz = zrms1*fzrms/float(nz)
        rmax = float(nr)*dr
        ! load rm, zm, rs, zs
        rm(1) = 0.0
        do i = 2, nr1
          rm(i) = float(i-1)*dr
          rssq(i-1) = .5*(rm(i-1)**2+rm(i)**2)
          rss(i-1) = 0.5*(rm(i-1)+rm(i))
          rs(i-1) = sqrt(rssq(i-1))
        end do
        zs = .5*dz
        do i = 1, nz1
          zm(i) = float(i-1)*dz
          zzs(i) = zm(i) + zs
        end do
        hl = float(nz)*zs
        ! load ers and ezs
        ! mesh dimensions are in cm. ers and ezs are in 1/cm.
        ! c1, c2 and c3 are in cm., and c4 is in mev-cm.
        ! q=coulombs/point.   (2/pi)*e/(4*pi*epsilon)=572167 cm mev/coul.
        q = beami/(freq*float(nq))
        c1 = 572167.*q/xmat
        l = 0
        do k = 1, nr
          rfac = (rm(k+1)**2-rm(k)**2)*dz/2.
          if (opt==0.) rfac = 1.
          do j = 1, nz
            zp = zm(j+1)
            do i = 1, nr1
              rp = rm(i)
              if (opt==0.) call flds(rs(k), zs, er1, ez1)
              if (opt==0.) go to 35
              call gaus(rm(k), rm(k+1), zm(1), zm(2), opt, er1, ez1)
35            l = l + 1
              ers(l) = c1*er1/rfac
              ezs(l) = c1*ez1/rfac
            end do
          end do
        end do
        dz1 = scdist/100.
        dist = scdist
        ! sup       WRITE(16, *) ' fields acting length(cm): ',DIST
        ! evaluate and apply space charge effects.
        ! phimc=phi of mesh center.
        ! Shifts particle coordinates to a single point in time. Uses
        ! a linear shift
        ! Beam c.g.
        xbar = 0.
        ybar = 0.
        zbar = 0.
        brmoy = 0.
        trmoy = 0.
        do np = 1, ngood
          if (f(9,np)==cstat(isp)) then
            gpai = f(7, np)/xmat
            brmoy = brmoy + sqrt(1.-1./(gpai*gpai))
            trmoy = trmoy + f(6, np)
          end if
        end do
        trmoy = trmoy/float(ngisp)
        phimc = trmoy*fh
        pbar = phimc
        beta = brmoy/float(ngisp)
        gsc = 1./sqrt(1.-beta*beta)
        bg = beta*gsc
        c3 = dist/bg
        c4 = dist*xmat
        ! evaluate ng, xbar, ybar, and pbar.
        c2 = beta*wavel/(2.*pi)
        gmsq = 1. + bg**2
        gam = sqrt(gmsq)
        ! evaluate ng, xbar, ybar
        ng = 0
        xbar = 0.
        ybar = 0.
        xsq = 0.
        ysq = 0.
        do np = 1, ngood
          if (f(9,np)==cstat(isp)) then
            ng = ng + 1
            x = f(2, np)
            y = f(4, np)
            xf = f(3, np)
            yf = f(5, np)
            xbar = xbar + x
            ybar = ybar + y
            xsq = xsq + x**2
            ysq = ysq + y**2
          end if
        end do
        eng = float(ngisp)
        xbar = xbar/eng
        ybar = ybar/eng
        ! the mesh center is phi*syn
        xsq = xsq/eng
        ysq = ysq/eng
        epsq = sqrt((xsq-xbar*xbar)/(ysq-ybar*ybar))
        epsqi = 1./epsq
        xfac = 2./(epsq+1.)
        yfac = epsq*xfac
        ! clear and load bins
        ng = 0
        do i = 1, im1
          aa(i) = 0.0
        end do
        do np = 1, ngood
          if (f(9,np)==cstat(isp)) then
            rsq = (f(2,np)-xbar)**2*epsqi + (f(4,np)-ybar)**2*epsq
            ! i=sqrt(rsq)/dr+1.
            r = sqrt(rsq)
            halfdr = dr*0.5
            i = idint(r/dr+1.0)
            if (i>nr) go to 120
            zph = f(6, np)*fh
            z = -c2*(zph-phimc)
            if (abs(z)>=hl) go to 120
            ! ------distribute charge among adjacent bins.
            ng = ng + 1
            zz = z + hl
            jm1 = idint(zz/dz+1.)
            i1 = i + 1
            ! if (rsq.lt.rssq(i)) i1=i-1
            if (rsq<rss(i)) i1 = i - 1
            if (i1<1) i1 = 1
            if (i1>nr) i1 = nr
            j1 = jm1 + 1
            if (zz<zzs(jm1)) j1 = jm1 - 1
            if (j1<1) j1 = 1
            if (j1>nz) j1 = nz
            a = 1.
            ! if (i1.ne.i) a=(rsq-rssq(i1))/(rssq(i)-rssq(i1))
            if (i1==i) then
              a = 1.
            else
              rdr2 = rsq/dr**2
              sqr = sqrt(4.*rdr2-1.)
              rminsq = (halfdr*(sqr-1.))**2
              rmaxsq = (halfdr*(sqr+1.))**2
              if (i1<i) then
                a = (rmaxsq-rm(i)**2)/(rmaxsq-rminsq)
              else
                a = (rm(i1)**2-rminsq)/(rmaxsq-rminsq)
              end if
            end if
            b = 1. - a
            cc = 1.
            if (j1/=jm1) cc = (zz-zzs(j1))/(zzs(jm1)-zzs(j1))
            d = 1. - cc
            k = (jm1-1)*nr + i
            aa(k) = aa(k) + a*cc
            k = k + i1 - i
            aa(k) = aa(k) + b*cc
            k = (j1-1)*nr + i
            aa(k) = aa(k) + a*d
            k = k + i1 - i
            aa(k) = aa(k) + b*d
          end if
120     end do
        eng = float(ng)
        ! find ismax for each j
        do j = 1, nz
          l = (j-1)*nr
          k = nr
          do i = 1, nr
            m = l + k
            if (aa(m)<=0.00) then
              k = k - 1
              go to 130
            else
              go to 140
            end if
130         continue
          end do
140       ismax(j) = k
        end do
        ! find iemax for each j
        iemax(1) = 1 + ismax(1)
        do j = 2, nz
          iemax(j) = 1 + max0(ismax(j-1), ismax(j))
        end do
        iemax(nz1) = 1 + ismax(nz)
        ! set er and ez to zero
        do i = 1, im2
          er(i) = 0.0
          ez(i) = 0.0
        end do
        ! sum up fields
        do js = 1, nz
          js1 = js + 1
          ism = ismax(js)
          if (ism==0) go to 220
          do is = 1, ism
            l = (js-1)*nr + is
            a1 = aa(l)
            if (a1==0.) go to 210
            l = (is-1)*im3
            do je = 1, js
              k1 = l + (js-je)*nr1
              n1 = (je-1)*nr1
              iem = iemax(je)
              if (iem<=1) go to 180
              do ie = 1, iem
                n = n1 + ie
                k = k1 + ie
                er(n) = er(n) + a1*ers(k)
                ez(n) = ez(n) - a1*ezs(k)
              end do
180         end do
            do je = js1, nz1
              k1 = l + (je-js1)*nr1
              n1 = (je-1)*nr1
              iem = iemax(je)
              if (iem<=1) go to 200
              do ie = 1, iem
                n = n1 + ie
                k = k1 + ie
                er(n) = er(n) + a1*ers(k)
                ez(n) = ez(n) + a1*ezs(k)
              end do
200         end do
210       end do
220     end do
        ! evaluate and apply impulse
        rrmax = 0.
        zzmax = 0.
        zzmin = 1000.
        npz = 0
        npr = 0
        do np = 1, ngood
          ! Transforming to the bunch reference frame

          if (f(9,np)==cstat(isp)) then
            dwc = f(7, np) - xmat
            gm1 = dwc/xmat
            ! convert xp an yp from mrad to rad
            f3np = f(3, np)*1.e-03
            f5np = f(5, np)*1.e-03
            ! omment   gm1*(2.+gm1)=(gam-1)*(gam+1)=gam*gam-1=beta*beta*gam*gam
            bgz = sqrt(gm1*(2.+gm1))
            bgx = bgz*f3np
            bgy = bgz*f5np
            gamma = 1. + gm1
            ! Particle momentum in the bunch frame

            bgzstar = gam*(bgz-beta*gamma)

            ! Particle energy in bunch frame

            gstar = gam*(gamma-beta*bgz)

            r = sqrt((f(2,np)-xbar)**2*epsqi+(f(4,np)-ybar)**2*epsq)
            if (r>=rrmax) rrmax = r
            if (r==0.) r = .000001
            xor = (f(2,np)-xbar)*xfac/r
            yor = (f(4,np)-ybar)*yfac/r
            if (r>rmax) then
              npr = npr + 1
              go to 230
            end if
            zph = f(6, np)*fh
            z = -c2*(zph-phimc)
            if (z>=zzmax) zzmax = z
            if (z<zzmin) zzmin = z
            if (abs(z)>hl) then
              npz = npz + 1
              go to 230
            end if
            ! interpolate impulse within mesh.
            rb = r/dr
            i = idint(1.+rb)
            a = rb - float(i-1)
            b = 1. - a
            zb = (z+hl)/dz
            j = idint(1.+zb)
            c = zb - float(j-1)
            d = 1. - c
            l = i + (j-1)*nr1
            m = l + nr1
            cbgr = c3*(d*(a*er(l+1)+b*er(l))+c*(a*er(m+1)+b*er(m)))
            cbgzs = c3*(d*(a*ez(l+1)+b*ez(l))+c*(a*ez(m+1)+b*ez(m)))
            cbgr = cbgr*abs(f(9,np))
            cbgzs = cbgzs*abs(f(9,np))
            go to 260
            ! estimate impulse based on point charge at xbar,ybar,pbar.
            ! estimate impulse based on point charge at xbar,ybar,pbar.
230         continue
            d = sqrt(z**2+r**2)
            rod3 = r/d**3
            zod3 = z/d**3
            if (nip==0) go to 250
            ! include neighboring bunches.
            do i = 1, nip
              xi = i
              do j = 1, 2
                s = z + xi*pl
                d = sqrt(s**2+r**2)
                rod3 = rod3 + r/d**3
                zod3 = zod3 + s/d**3
                xi = -xi
              end do
            end do
            ! Evaluate impulse.

250         cbgr = eng*c1*c3*rod3*pi/2.
            cbgzs = eng*c1*c3*zod3*pi/2.
            cbgr = cbgr*abs(f(9,np))
            cbgzs = cbgzs*abs(f(9,np))

            ! Apply impulse and transform back to lab frame.

260         bgx = bgx + cbgr*xor
            bgy = bgy + cbgr*yor
            bgzstar = bgzstar + cbgzs
            gstar = 1. + 0.5*bgzstar**2
            bgzf = gam*(bgzstar+beta*gstar)
            f3 = bgx/bgzf
            f5 = bgy/bgzf
            dww = f(7, np) - xmat
            dws = dww*((gamma+1.)/gamma)*(bgzf-bgz)/bgz
            ! ********************
            if (.not. iesp) then
              ! load the entrance beam parameters for cavities or gaps
              do js = 1, 7
                f(js, np) = fs(js, np)
              end do
              ! dxp and dyp are the jumps of xp and yp (in rad) at the position dz1*xpsc (in m)
              dxp = f3 - f3np
              dyp = f5 - f5np
              ! correction of xp and yp ( in rad)
              f(3, np) = f(3, np) + dxp*1000.
              f(5, np) = f(5, np) + dyp*1000.
              f(2, np) = f(2, np) - dz1*100.*dxp*xpsc
              f(4, np) = f(4, np) - dz1*100.*dyp*xpsc
              dwp(np) = dws
            else
              f(3, np) = f3*1000.
              f(5, np) = f5*1000.
              f(7, np) = f(7, np) + dws
            end if
          end if
        end do
        ! big enddo of isp
      end do
      return
    end subroutine scheff_sep
    ! *******************************************************************
    ! SUBROUTINE rfkick(v,dp,harm,nvf)
    ! RFKICK  (NO SPACE CHARGE EFFECT)

    ! Contributing Author: Daniel Alt, NSCL/MSU, East Lansing,  MI, USA
    ! Date: 23-May-2014

    ! Electric RF kicker.  Simulates a sine wave chopper consisting
    ! of two plates deflecting the beam in the transverse direction.
    ! This is a zero length element.

    ! V:    Voltage Factor.  Consists of plate voltage in kV, times
    ! the electrode length divided by the gap between them.
    ! DP:   RF phase offset in radians
    ! Harm: Kicker harmonic number relative to current reference
    ! frequency
    ! NVF:  Kicker axis: 0 = horziontal, 1= vertical (use negative
    ! voltage for negative deflection)
    ! *******************************************************************
    subroutine rfkick(v, dp, harm, nvf)
      implicit real *8(a-h, o-z)
      parameter(iptsz=100002, maxcell=3000, maxcell1=3000)
      common /rigid/boro
      common /consta/vl, pi, xmat, rpel, qst
      common /dyn/tref, vref
      common /davcom/dav1(maxcell1, 40), davtot, iitem(maxcell1), idav
      common /etcha1/dav2(maxcell1, 33), ichas(iptsz), chasit
      common /ttfc/tk, t1k, t2k, sk, s1k, s2k, fh
      common /faisc/f(10, iptsz), imax, ngood
      common /etcom/cog(8), exten(17), fd(iptsz)
      common /fene/wdisp, wphas, wx, wy, rlim, ifw
      common /corec/tref1
      common /qmoyen/qmoy
      common /aerp/vphase, vfield, ierpf
      common /itvole/itvol, imamin
      common /compt/nrres, nrtre, nrbunc, nrdbun
      common /shif/dtiph, shift
      common /tofev/ttvols
      character *1 cr
      ! dimension vecx(1)
      logical chasit, itvol, imamin, shift
      ! ENVELOPE
      call stapl(davtot*10.)
      ! xx       ilost=0
      twopi = 2.*pi
      freq = fh/twopi
      wavel = vl/freq
      fcpi = fh*180./pi
      ! print out on terminal of transport element # on one and the same line
      cr = char(13)
      write (6, 8254) nrtre, cr
8254  format ('Transport element:', i5, a1, $)
      if (harm<=0.) harm = 1.
      ! test window - unneccesary at START of element - Alt
      ! call reject(ilost)
      ! Calculate tof, beta, gamma, k.e. for c.o.g.
      tcog = 0.
      bcog = 0.
      do np = 1, ngood
        tcog = tcog + f(6, np)
        gpa = f(7, np)/xmat
        bcog = sqrt(1.-1./(gpa*gpa)) + bcog
      end do
      tcog = tcog/float(ngood)
      bcog = bcog/float(ngood)
      gcog = 1./sqrt(1.-bcog*bcog)
      encog = xmat*gcog - xmat
      ! adjustement of the phase of RF w.r.t. the T.O.F.
      xkpi = 0.
      if (imamin) then
        ttvpi = harm*ttvols*fcpi
        xkpi = ttvpi/360.
        ixkpi = int(xkpi)
        xkpi = (xkpi-float(ixkpi))*360.
        write (16, *) ' *** TOF correction:', -xkpi, ' deg'
        dp = dp - xkpi*pi/180.
        write (16, *) ' ***phase of RF adjusted : ', dp*180./pi, ' deg'
      end if
      ! start of write to file '.short' for kicker
      idav = idav + 1
      iitem(idav) = 22
      dav1(idav, 1) = v
      dav1(idav, 2) = dp*180./pi
      dav1(idav, 3) = nvf
      dav1(idav, 4) = davtot*10.
      ! if(itvol) dav1(idav,5)=-xkpi
      dav1(idav, 5) = harm
      ! end
      write (16, 178)
178   format (/, ' Longitudinal parameters', /, 5x, '   BETA     GAMMA      ENERGY(MeV) ', &
        '       TOF(deg)     TOF(sec)')
      write (16, 1788) bcog, gcog, encog, tcog*fcpi, tcog
1788  format (' COG ', f7.5, 3x, e12.5, 1x, e12.5, 3x, e12.5, 3x, e12.5)
      e0t = harm*v/(bcog*wavel)
      cay = harm*twopi/(bcog*gcog*wavel)
      caysq = cay**2
      con = twopi*e0t*qmoy/xmat
      rad = pi/180.
      ! shift=true => reference and COG seperated, otherwise reference=COG
      ! --- save the reference
      ovref = vref
      otref = tref
      ! --- shift = false: the reference particle is the cog
      if (shift) then
        ovref = vref
        beref = vref/vl
        gamref = 1./sqrt(1.-beref*beref)
        older = xmat*gamref
      else
        tref = tcog
        vref = bcog*vl
        ovref = vref
        beref = bcog
        gamref = 1./sqrt(1.-beref*beref)
        older = xmat*gamref
      end if
      ! ---  if imamin = false: phase setting has been forced equal to dp, otherwise phase setting has been adjusted
      enrprin = older - xmat
      write (16, 165) beref, gamref, enrprin, tref*fh*180./pi, tref
165   format (' REF ', f7.5, 3x, e12.5, 1x, e12.5, 3x, e12.5, 3x, e12.5)
      wsync = 0.
      bcour = 0.
      tcog = 0.
      do np = 1, ngood
        a = harm*(f(6,np)-tref+ttvols)*fh + dp
        s = sin(a)
        w = f(7, np) - xmat
        gpai = f(7, np)/xmat
        bg = sqrt(w/xmat*(2.+w/xmat))
        bpai = bg/gpai
        const = (gpai/(gpai*gpai-1.))*f(9, np)
        disp = const*v/xmat*s
        bcour = bcour + bpai
        tcog = tcog + f(6, np)
        if (nvf==0) then
          f(3, np) = f(3, np) + disp
        else if (nvf==1) then
          f(5, np) = f(5, np) + disp
        else
          write (6, *) 'Invalid parameter NVF in RFKICK'
        end if
        wsync = wsync + w
      end do
      wsync = wsync/float(ngood)
      bcour = bcour/float(ngood)
      tcog = tcog/float(ngood)
      ! Test window
      call reject(ilost)
      ! dave start for kicker
      dav1(idav, 36) = ngood
      call emiprt(0)
      return
    end subroutine rfkick